I created this function to go through my current sheet and delete all shapes starting with "Stn_".
It deletes a few at a time. I end up running it multiple times to delete them all.
Private Sub btnReset_click()
'Reset Shapes needs work
For Each shp In ActivePage.Shapes
Debug.Print shp.Name
If shp.Name Like "Stn_*" Then
ActiveWindow.Select shp, visSelect
ActiveWindow.Selection.Delete
End If
Next
End Sub
You need to count backwards when deleting shapes. If you, say, delete shape 1, then shape 2 then becomes the new shape 1 but the loop counter moves on to 2, bypassing that shape. So you can't use For Each, you have to use a plain old For but count by -1.
Related
Need some help!
I'm relatively knowledgeable when it comes to macros, VBA, scripts, etc., but Visio coding is an all new monster to me.
In short, I have a warehouse map layout with simple square shapes marking product locations, and I want to color-code the squares based on their Prop._VisDM_F2 data element. My code so far seems to work, but only for the 1st shape in the group of squares, but sometimes the master shape consists of 1 square, sometimes 6, and everything in between.
I've learned that the # in "Shapes(#)" selects which square gets changed, but I want them ALL to change. I've tried to get a count of how many individual shapes are in each master shape to use a variable integer as the #, but it didn't work.
Surely such a simple task can't really this complicated so I'm probably just missing something a step. Any help would be greatly appreciated!
'''
Dim selectObj As Visio.Shape
For Each selectObj In ActiveWindow.Selection
If selectObj.CellExistsU("Prop._VisDM_F2", Visio.VisExistsFlags.visExistsAnywhere) Then
selectObj.Shapes(1).Cells("Fillforegnd").FormulaU = visWhite
End If
Next
End Sub
'''
Shapes can have sub-shapes which are accessed through the Shapes property as per your code (note that most Visio collections are 1 rather than 0 based).
You can address the sub-shapes collection either by index or with a further for each. So given that you may or may not know the depth of your sub-shapes you can recurse through them something like this:
Sub ApplyFillToAll()
Dim shp As Visio.Shape
For Each shp In ActiveWindow.Selection
If shp.CellExistsU("Prop._VisDM_F2", Visio.VisExistsFlags.visExistsAnywhere) Then
SetFill shp, "RGB(255,0,0)"
End If
Next
End Sub
Public Sub SetFill(ByRef shpIn As Visio.Shape, fillFormula As String)
Dim shp As Visio.Shape
For Each shp In shpIn.Shapes
shp.Cells("FillForegnd").FormulaU = fillFormula
SetFill shp, fillFormula
Next
End Sub
Note that the formula that you're setting is a string and so is wrapped in double quotes, and the above will set all of the sub-shapes to red with the SetFill method calling itself to navigate down through the tree.
I'll add a link to a very old post that you might also find useful:
https://visualsignals.typepad.co.uk/vislog/2007/11/looping-through.html
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 to my question in determining how to see if a shape has overflowed a page boundary (Determining if a powerpoint text box is over the page size)
I need to move rows of a table on one page to the prior page.
Fairly straightforward to determine the rows I need to cut (I've left that part of the code out for brevity). Where I am having a problem is the method of how to paste it back into the table on the prior page (table has same column dimensions).
In the UI, it is as simple as placing the cursor in the first cell of the target row and hitting paste. This completely replicates the column structure of the cut row. In VB, best I can do is paste the entire text of the cut row (all columns) gets into the one cell. I cant seem to get VB code that can replicate what is happening in the UI. What command am I missing?
For y = 2 To c
Set oSh = ActivePresentation.Slides(k + 1).Shapes("ProgTable")
With oSh.Table
.Rows(y).Select
End With
Windows(1).Selection.Cut
Set oSh = ActivePresentation.Slides(k).Shapes("ProgTable")
With oSh.Table
.Rows.Add (-1)
.Cell(oSh.Table.Rows.Count,1)textFrame.TextRange.Paste 'pastes all columns into the one cell
End With
Next y
Alternate line of code to paste clipboard that I can't get to work
.Rows(oSh.Table.Rows.Count).Cells.Item.Shape.TextFrame.TextRange.PasteSpecial (PpPasteDataType.ppPasteHTML)
'does not work, gives compile error on ITEM argument not optional
You're pasting in to a TextRange, not the table/row itself. There are some funky things in PPT's object model for sure, and some actions which seem like they should be intuitive (copy/paste) often are not. In these cases, the Application.CommandBars.ExecuteMSO method is usually where I start (also very useful if you're copying from/between different applications like Excel>PowerPoint, Word>PowerPoint, etc.)
I did this to test, and it is working as expected, so it should set you on the right track:
Sub CopyRowToAnotherTable()
Dim tbl1 As Table
Dim tbl2 As Table
Dim sld1 As Slide
Dim sld2 As Slide
Dim pres As Presentation
Dim shp As Shape
Set pres = ActivePresentation
Set sld1 = pres.Slides(1)
Set sld2 = pres.Slides(2)
Set tbl1 = sld1.Shapes(1).Table
Set tbl2 = sld2.Shapes(1).Table
'Cut the last row from tbl2:
sld2.Select '## Powerpoint requires the slide to be active/view in order to select shapes on the slide
With tbl2
.Rows(.Rows.Count).Select
pres.Windows(1).Selection.Cut
End With
'Insert in tbl1
With tbl1
.Rows.Add -1
sld1.Select
.Rows(.Rows.Count).Select
pres.Application.CommandBars.ExecuteMso "Paste"
End With
End Sub
So in your code, I think this should work:
With oSh.Table
'## select the slide:
.Parent.Parent.Select
.Rows.Add (-1)
.Rows(.Rows.Count).Select
Application.CommandBars.ExecuteMso "Paste"
End With
The tricky part about the ExecuteMso method is mainly that it's not well-documented, or it is, but it's hard to find the dox, so here is reference from a previous answer:
Documentation on the ExecuteMso method:
http://msdn.microsoft.com/en-us/library/office/ff862419.aspx
Downloadable document containing the idMSO parameters for each Office
Application:
http://www.microsoft.com/en-us/download/details.aspx?displaylang=en&id=6627
Apologies this seems rather basic, but i can't seem to find adequate documentation on it.
I essentially need to cycle through the rows in "Shape Data" on the shape sheet, using VBA in Visio 16. The code i'm looking for (I imagine) will look somewhat like this:
sub printLabelsAndProps()
for each x in UnknownGroupOfThings
debug.print x.prop.DataAndDocuments
debug.print x.prop.Supports
Next
end sub
Help appreciated
In case you know that all your shapes have "DataAndDocuments" and "Supports" properties, you could use something like the code below (otherwise you may need to check if the shape has those properties using .CellExists). Also if your cells contain calculated strings, then you should use .ResultStr() instead of .Formula. If those values are numbers, you can even go without .Formula
Sub printLabelsAndProps()
For Each x In ActivePage.Shapes
Debug.Print x.Cells("Prop.DataAndDocuments").Formula
Debug.Print x.Cells("Prop.Supports").Formula
Next
End Sub
If you want to cycle through all properties for a single shape, you could go with something like this:
Sub showAllProperties(x As Shape)
For i = 0 To x.Section(visSectionProp).Count - 1
Debug.Print x.CellsSRC(visSectionProp, i, visCustPropsLabel).Formula
Debug.Print x.CellsSRC(visSectionProp, i, visCustPropsValue).Formula
Next
End Sub
I noticed my worksheet was slowing right down, and found a few objects had been created for some reason. I ran the following macro to remove them all:
Dim Shp as Shape
For Each Shp In Worksheets("Sheet1").Shapes
Shp.Delete
Next Shp
However I keep getting The index into the specified collection is out of bounds error. So I did the following to see how many objects had been created:
Dim i As Long
i = ActiveSheet.Shapes.Count
MsgBox CLng(i)
And received the number 41152. I have tried Go To Special and selected objects, but if this number is correct my computer is crashing trying to select over 41K objects at once.
Any suggestions how to remove them all?
You can step backward through the Shapes collection to delete them from the last value in the collection Index to the first.
Like this:
i = Worksheets("Sheet1").Shapes.Count
For x = i To 1 Step -1: Worksheets("Sheet1").Shapes(x).Delete: Next