Export data from Visio Shapes using VBA - vba

I want to model something similar to a (hyper-)graph in MS Visio 2016 Professional and then export the data of the shapes to csv to further work with it.
I am trying to make a VBA Script that goes through all the shapes on the sheet and writes the (manually inserted) data from the shapes to one csv file (and in the future maybe different csv files depending on the type of the shape).
To get a feeling for VBA I tried to start with a script that counts all the shapes on the sheet but I already failed on that. Please consider this is my first time working with VBA:
Sub countShapes()
Dim shp As Shape
Dim count As Integer
count = 0
Debug.Print count
For Each shp In ActiveSheet.Shapes
count = count + 1
Debug.Print count
Next
End Sub
This returns runtime error 424, object not found.
What am I missing?
As a second step, I want the script to check that shapes that have for example the same number in the data field "id" are identical in all other data fields as well and show an error if not (before exporting to the csv files). Can I realize this using vba in visio?
Thanks a lot for any help!

ActiveSheet is an Excel property. I think you're looking for ActivePage, which is a Visio equivilent. So to fix your code above you could use this:
For Each shp In ActivePage.Shapes
count = count + 1
Debug.Print count
Next
However, if you're simply after the shape count for a page then you could write this instead:
Debug.Print ActivePage.Shapes.Count
Can I recommend some links that might also help:
http://visualsignals.typepad.co.uk/vislog/2007/10/just-for-starte.html
http://visualsignals.typepad.co.uk/vislog/2007/11/looping-through.html
vba programming for visio
As an alternative approach you might also be interested in Visio's built-in reporting tool:
Create a report of shape data (support docs)
Getting Started with Visio 16 - Build and Apply Reports from Share Data (Video)
Re the second part of your question (check data fields) I'm assuming you're talking about reading Shape Data. If that's the case you first want to check if a row named "ID" exists and, if it does, read that value. So something like this might get you going:
Public Sub TestGetCellValues()
GetShapesCellValues ActivePage, "Prop.ID"
End Sub
Public Sub GetShapesCellValues(targetPage As Visio.Page, targetCellName As String)
Dim shp As Visio.Shape
If Not targetPage Is Nothing Then
For Each shp In targetPage.Shapes
If shp.CellExistsU(targetCellName, 0) = True Then
Debug.Print shp.NameID & "!" _
& targetCellName & " = " _
& shp.CellsU(targetCellName).ResultIU
End If
Next shp
End If
End Sub
...which might output something like this (given the associated shapes):
Sheet.2!Prop.ID = 3

Related

Permission denied on MS Word macro

I have an MS Word document (Office 365 version 1803) with a large number of images. I need to select all images in the document, but there are far too many to do this by hand. Looking online, it seems the only way to do this is using a macro, which I have no experience with. I wrote the following very simple macro:
Sub SelectAllImages()
ActiveDocument.Shapes.SelectAll
End Sub
When I saved the document, I was forced to change it to a macro-enabled Word document (.docm), which I did. However, whenever I try to run the macro I get the following error:
Run-time error '70': Permission denied
I have Googled this error, but nothing has helped me fix it. Anyone have any idea what I'm doing wrong?
Edit: As additional data, what I'm trying to do is delete most but not all of the images. I have a document that is 200+ pages long with an average of about 1 image per page. I need to publish 2 versions of this document: 1 with all images, the second with all but about 12 of the images removed. The document is updated regularly, and I don't want to have to keep updating 2 separate versions and ensure they are identical except for the inclusion of the images. Thus I'd like to be able to maintain only one version, which includes all the images. Then after each update I'd like to be able to select all the images, manually unselect the 12 I want to keep, and delete the others.
If there is a way to somehow "tag" the images I want to keep and have a macro delete all but the tagged ones that would be an even better solution.
You will get that error if there are any InlineShapes in the document. There only has to be one and that command will error out. You will have to select InlineShapes separately from Shapes with wrapping text. See code below.
Concerning your question about tagging. To "Tag" the images put a unique phrase like "Do Not Delete" in the Alt Text of the images. Then you can use code like the below to remove all images, except those that have been tagged.
For Inline Images this code will potentially leave a blank paragraph in the document and I will leave that to you to figure out how you want the final document to look.
Sub RemoveAllImagesWithExceptions()
Dim doc As Word.Document, iShp As Word.InlineShape
Dim shp As Word.Shape, i As Long, rng As Word.Range
Set doc = ActiveDocument
Set rng = doc.Content
For i = rng.InlineShapes.Count To 1 Step -1
Set iShp = rng.InlineShapes(i)
Select Case iShp.Type
Case wdInlineShapeLinkedPicture, wdInlineShapePicture
If InStr(1, iShp.AlternativeText, "Do Not Delete") = 0 Then
iShp.Delete
End If
End Select
Next
For i = rng.ShapeRange.Count To 1 Step -1
Set shp = rng.ShapeRange(i)
Select Case shp.Type
Case msoLinkedPicture, msoPicture
If InStr(1, shp.AlternativeText, "Do Not Delete") = 0 Then
shp.Delete
End If
End Select
Next
End Sub

Power point tables linked to excel - How to change source (VBA)?

I have big presentation (~300 slides) And i need to make few versions of it, each connected to diffrent excel file. I have code that changes links for all shapes inside prestations. Its all good for charts, but there is problem with linked tables. Source change is correct, but during this change range for table dissapires (range is set for 1st sheet cell A1).
Is there way to keep the range unchanged?
Additional question: changing chart source is very fast (<1s),whereas changing linked table source takes some time (~15s). This becomes a problem where there is a lot tables.
When i run code few times ~50 slides in one run it went well (took ~5-10min), but when i tried run it on all ~300 slides i waited for 30min and it didn't finish (there was no crush, it looked like procedure frozed). Im really curious why this problem occures.
Belowe code i use for link change:
Sub UpdateLinks()
Dim ExcelFile
Dim exl As Object
Set exl = CreateObject("Excel.Application")
'Open a dialog box to promt for the new source file.
ExcelFile = exl.Application.GetOpenFilename(, , "Select Excel File")
Dim i As Integer
Dim k As Integer
'Go through every slide
For i = 1 To ActivePresentation.Slides.Count
With ActivePresentation.Slides(i)
'Go through every shape on every slide
For k = 1 To .Shapes.Count
'Turn of error checking s that it doesn 't crash if the current shape doesn't already have a link
On Error Resume Next
'Set the source to be the same as teh file chosen in the opening dialog box
.Shapes(k).LinkFormat.SourceFullName = ExcelFile
If .Shapes(k).LinkFormat.SourceFullName = ExcelFile Then
'If the change was successful then also set it to update automatically
.Shapes(k).LinkFormat.AutoUpdate = ppUpdateOptionAutomatic 'other option is ppUpdateOptionManual/ppUpdateOptionAutomatic
End If
On Error GoTo 0
Next k
End With
Next i
End Sub
All tips are welcome! :)
Have you looked at what .SourceFullName returns? Usually it's not just the file name but also further code that indicates what sheet and range within the sheet the link points to. It looks like you're changing that to just the name of the replacement Excel file.
Instead, try using Replace to substitute the name of the new Excel file for the name of the old Excel file in .SourceFullName. That'll leave the rest of the link text intact.

Endless loop with read/update database record from and to excel by using vba in visio

Hello guys from stackoverflow,
i’m currently create a tool with Excel and Visio to gather all the data about our it infrastructure that our it-department has a big picture of our it-assets. It’s pretty cool to collect all data with excel and draw a network map of our assets with visio shapes. But one thing is really important for us in case of this tool, we want a bidirectional connection between them to be able to do changes in excel (and visio recognizes) and we want to change shape-data in visio (and write it down to excel). In visio you can manually update the excel-file by clicking "update record in database" and load data from excel by choosing "update shape-data" in the context-menu of a shape. In the shape-sheet of a shape i have a row e.g. User. StartMakro_IP in the section user-defined Cells. In this field i have a formula =CALLTHIS("update_item")+DEPENDSON(Prop.IP). This formula calls the update_item method (located in the modul „mdl_admin“) to write down changes to my excel-file:
Public Sub update_item(shp As Visio.Shape)
If shp.CellExists("User.ODBCConnection", Visio.visExistsAnywhere) <> 0 Then
'Loop thru to check if shape has refresh action
If shp.SectionExists(Visio.visSectionAction, Visio.visExistsAnywhere) <> 0 Then
For iRow = 0 To shp.RowCount(Visio.visSectionAction) - 1
If shp.CellsSRC(Visio.visSectionAction, iRow, Visio.visActionAction).Formula = "RUNADDON(""DBU"")" Then
'Force the cell formula to run
shp.CellsSRC(Visio.visSectionAction, iRow, Visio.visActionAction).Trigger
Exit For
End If
Next iRow
End If
End If
End Sub
To be able to load latest changes out of excel we call the method selectionchanged everytime a shape is selected. This method is located in ThisDocument and implemented as follows:
Dim WithEvents MyWindow As Visio.Window
Private Sub Document_RunModeEntered(ByVal doc As IVDocument)
Set MyWindow = ActiveWindow
End Sub
Private Sub MyWindow_SelectionChanged(ByVal Window As IVWindow)
If Window.Selection.Count = 1 Then
If Window.Selection(1).CellExists("User.ODBCConnection", Visio.visExistsAnywhere) <> 0 Then
'Loop thru to check if shape has refresh action
If Window.Selection(1).SectionExists(Visio.visSectionAction, Visio.visExistsAnywhere) <> 0 Then
For iRow = 0 To Window.Selection(1).RowCount(Visio.visSectionAction) - 1
If Window.Selection(1).CellsSRC(Visio.visSectionAction, iRow, Visio.visActionAction).Formula = "RUNADDON(""DBR"")" Then
'Force the cell formula to run
Window.Selection(1).CellsSRC(Visio.visSectionAction, iRow, Visio.visActionAction).Trigger
'MsgBox Window.Selection(1).Name
Exit For
End If
Next iRow
End If
End If
End If
End Sub
In my mind the matter is, that the currently implemented methods triggers themselves (database update / read data from database) and so an endless loop will appear. In fact Visio crashes at this time and the application will unfortunately closes down.
Does anyone know another method to write changed shape-data from current visio-shape to excel and simultaneously read new data from excel and update shape-data of the current selected visio-shape?
Any help is highly appreciated. If possible please provide any tiny example codes to catch that exception, because i'm not really familiar with events in visio.
Best regards
Joerg
The BackSync addin from here (visguy.com/vgforum/index.php?topic=6086.msg24731#msg24731) solve all the problems and reduces a lot of pain!

Error 1004 with VBA code with bookmarks

I am using a macro to populate a word document with text from named ranges in excel. The word document has bookmarks that correspond with the named excel ranges. I did not write the code, but rather copied it from another source.
There is quite a bit more to this macro than the snippet I posted. I could post the rest if that is useful. I had about half of my word document bookmarked and the macro was working fine then it suddenly stopped working.
I am receiving a error 1004 in the line highlighted below. I am a newbie so I'm not even quite sure what I should be searching for to fix this issue. Any assistance you could provide would be appreciated! Thanks in advance!
P.S. In case it's relevant, I am using Word and Excel 2007
'PASTE TEXT STRINGS LOOP
n = 1
For Each temp In BkmTxt
p = p + 1
Prompt = "Please wait. Copying text. Carrying out operation " & p & " of " & pcount & "."
Application.StatusBar = Prompt
'If The Bkmtxt(n) is empty then go to the next one, once that has been found do next operation.
If BkmTxt(n) = Empty Then
n = n + 1
'should find match and work
Else
'You might want to use multiple copies of the same text string.
'In this case you need to call the bookmark as follows: "ARTextWhatever_01"
'You can use as many bookmarks as you want.
BkmTxtSplit = Split(BkmTxt(n), "_")
vValue = Range(BkmTxtSplit(0)).Text **<----- ERROR HERE**
Set wdRng = wdApp.ActiveDocument.Bookmarks(BkmTxt(n)).Range
If Len(sFormat) = 0 Then
'replace the bookmark text
wdRng.Text = vValue
Else
'replace the bookmark text with formatted text
wdRng.Text = Format(vValue, sFormat)
End If
'Re-add the Bookmark
wdRng.Bookmarks.Add BkmTxt(n), wdRng
n = n + 1
End If
Next
Step 1: Don't copy code from external sources. Use external sources as a learning tool and try to understand what they are actually doing.
Now if I understand you correctly, you simply have an Excel sheet with named ranges, I assume they have information already within them, and a word document with bookmarks that EXACTLY match the named ranges:
Step 2: Make sure you have the word object library reference within excel
Here:
sub KeepItDoin()
dim xlRange as Excel.Range
dim wdApp as new Word.Application
dim wdDoc as Word.Document
dim wdBkm as Word.Bookmark
set wdDoc = wdApp.Documents.Open( "Filepath" ) 'get filepath from where ever
for each wdBkm in wdDoc.Bookmarks
set xlRange = Application.Range(wdBkm.Name)
wdBkm.range.text = xlRange.Value
next wdBkm
end sub
That will get you close probably (didn't test, don't care if it works. Use it to learn). The idea is that if the bookmarks match up to the range, we can use their names to find the ranges in excel and then tell excel to move the data within it into the bookmarks range.
You will likely need to add some formatting or maybe create a table and then move cell by cell in the range and fill the table but this is as close as I'm willing to get since you like to copy pasta.
In case anyone is interested, I figured it out. There was an error with the bookmarks I inserted into my Word document. This macro returns Error 1004 if the word document contains a bookmark that does not correspond to a range in excel. Thank you for your help.

Counting shapes by name in Visio

I want to count different types of shapes in my diagram, and I can't seem to get that done. I think I have to code something for that.
I use Visio 2007 for that.
I have a flow chart with mostly process shapes that I want to distinguish by name. E.g "Type A", "Type B". And at the end, I want to have a list that tells me how often I used Type A and Type B. Counting by hand will be to error prone.
I already checked out the report/statistic function (I'm using it in German, so I'm afraid I can't tell you the exact menu name), where you can define a report function by yourself, although that one misses features for my needs. I managed to make a report for my shapes, but only when they all are selected. But when the user has to select them by hand, then he can count them as well right from the start... And you have to make 4-5 clicks in order to get that static report result.
Another almost useful function I found was the layer method: Create a layer for the types I want to count, and then assign the shapes to that layer. But, again, this is too error prone. If the user misses a shape, the count will be wrong.
So I think I will need to code something with the VBA.
Additionally, I'd like to have a text field next to my diagram where the resulting counts for all types are always displayed. So that you see when you add a shape of Type A that the count goes up by one.
Could anyone help me on this?
try:
Option Explicit
Dim myShape As Shape
Sub ShapesDetails()
Call DeleteShapes(True)
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 139.5, 81.75, 72, 72).Select
Selection.Name = "Rectangle"
ActiveSheet.Shapes.AddShape(msoShapeSmileyFace, 252.75, 71.25, 72, 72).Select
Selection.Name = "Smiley Face"
Application.CutCopyMode = False
Call ShapeDetails(True)
End Sub
Sub ShapeDetails(x As Boolean)
For Each myShape In ActiveSheet.Shapes
MsgBox "Shape name: " & myShape.Name & vbTab & " Shape type: " & myShape.Type
Next
End Sub
Sub DeleteShapes(x As Boolean)
For Each myShape In ActiveSheet.Shapes
myShape.Delete
Next
End Sub
Use Data= reports = advanced to configure a report to count objects with your custom shape Property (e.g. 'MIO') && exists. (Or another field, many to choose from). I set all the boxes i wanted to count to have property 'MIO'=TRUE, and then chose to display property Displayed Text. It takes some fiddling around in the Subtotals dialog and options in the next window to get the count looking nice. Leave COUNT unticked, and in the options dialog enable 'show all values' and tick 'exclude duplicate rows from group'.
Outputs as XML Excel Viso object. I know for the visio object, to update report, right click on it =Run report.
HTH