I just tried to add my container on\off button altering your code like so and it, of course, failed for me
Sub Macro1()
'Macro loops thru all shapes. Finds shapes that have a second (Icon) shape placed
'within border using Spatial Neighbor method. Creates necessary grouping. Locks position and size of icon, adds
'Action menu item to show/hide the icon.
'It assumes all shapes have been properly built and placed.
'The physical placement of the icon has the offset hardcoded.
'There is no error checking.
Dim intTolerance As Integer
Dim vsoReturnedSelection As Visio.Selection
Dim strSpatialRelation As String
Dim intSpatialRelation As VisSpatialRelationCodes
Dim vMain As Visio.Shape
Dim vIcon As Variant
strSpatialRelation = ""
intTolerance = 0.05
intSpatialRelation = visSpatialContain
For Each vMain In ActivePage.Shapes 'This construct needs to manual selecction
'check to see if shape has containing neighbor. If so select it.
ActiveWindow.DeselectAll
On Error Resume Next
Set vsoReturnedSelection = vMain.SpatialNeighbors(intSpatialRelation, intTolerance, 0)
If vsoReturnedSelection.Count = 1 Then
Debug.Print "Main shape: ", vMain.Name
ActiveWindow.Select vMain, visSelect
' setPgZm vMain 'Handy subroutine. Using F8 to step code. Takes windo to active vMain
' Add vMain Actions here
If Not vMain.CellExistsU("Actions.Icon", False) Then
vMain.AddSection visSectionAction
vMain.AddRow visSectionAction, visRowLast, visTagDefault
vMain.CellsSRC(visSectionAction, 0, visActionMenu).RowNameU = "Icon"
vMain.CellsSRC(visSectionAction, 0, visActionAction).FormulaU = "SETF(GETREF(Actions.Icon.Checked),NOT(Actions.Icon.Checked))"
vMain.CellsSRC(visSectionAction, 0, visActionMenu).FormulaU = "IF(Actions.Icon.Checked,""Show Icon"",""Hide Icon"")"
End If
'Add msvStrcutureType container
If Not vMain.CellExistsU("User.Container", False) Then
vMain.AddSection visSectionUser
vMain.AddRow visSectionUser, visRowLast, visTagDefault
vMain.CellsSRC(visSectionUser, 0, visUserValue).RowNameU = "msvStructureType"
vMain.CellsSRC(visSectionUser, 0, visUserValue).FormulaU = "SETF(GETREF(User.msvStructureType),0)"
End If
'Add container on action
If Not vMain.CellExistsU("Action.ContainerOn", False) Then
vMain.AddRow visSectionAction, visRowLast, visTagDefault
vMain.CellsSRC(visSectionAction, 0, visActionMenu).RowNameU = "ContainerOn"
vMain.CellsSRC(visSectionAction, 0, visActionAction).FormulaU = "SETF(GetRef(User.msvStructureType),""Container"")&SETF(GetRef(Actions.ContainerOff),""Container Off"")&SETF(GetRef(Actions.ContainerOn),"""")"
vMain.CellsSRC(visSectionAction, 0, visActionMenu).FormulaU = "Container Off"
End If
'Add Container Off Action
If Not vMain.CellExistsU("Action.ContainerOff", False) Then
vMain.AddRow visSectionAction, visRowLast, visTagDefault
vMain.CellsSRC(visSectionAction, 0, visActionMenu).RowNameU = "ContainerOff"
vMain.CellsSRC(visSectionAction, 0, visActionAction).FormulaU = "SETF(GetRef(User.msvStructureType),"""")&SETF(GetRef(Actions.ContainerOn),""Container On"")&SETF(GetRef(Actions.ContainerOff),"""")"
vMain.CellsSRC(visSectionAction, 0, visActionMenu).FormulaU = ""
End If
' Convert vMain to group object
vMain.ConvertToGroup
vMain.CellsU("DisplayMode").Formula = "1"
For Each vNbr In vsoReturnedSelection
Set vIcon = vNbr
ActiveWindow.Select vIcon, visSelect
Debug.Print "Icon: ", vIcon.Name
Next
ActiveWindow.Selection.AddToGroup 'Add vIcon to the group
' Lock vIcon size and position
vIcon.CellsU("Width").Formula = vIcon.CellsU("Width").ResultStr(visNone)
vIcon.CellsU("Height").Formula = vIcon.CellsU("Height").ResultStr(visNone)
vIcon.CellsU("PinX").FormulaU = "LocPinX + 0.03125"
vIcon.CellsU("PinY").FormulaU = vMain & "!Height*1-(Height-LocPinY)-0.03125"
' Iterate thru subshapes of vIcon
For Each shp In vIcon.Shapes 'goes thru the Icon group shape and modifies the subshapes
Debug.Print shp.Name 'name of member subshape
shp.CellsU("Geometry1.NoShow").Formula = vMain & "!Actions.Icon.Checked"
Next
End If
Next
End Sub
Sub setPgZm(vsoShp As Shape)
Dim winMag As Double
Dim shpWid As Double
Dim shpHt As Double
Dim pgWid As Double
Dim pgHt As Double
Dim widRatio As Double
Dim htRatio As Double
'Use shape based upon selection:
Application.Settings.CenterSelectionOnZoom = True
' Set vsoShp = ActiveWindow.Selection(1)
pgWid = ActivePage.PageSheet.CellsU("PageHeight").Result(inch)
shpWid = vsoShp.CellsU("Width").Result(inch)
widRatio = pgWid / shpWid
pgHt = ActivePage.PageSheet.CellsU("PageWidth").Result(inch)
shpHt = vsoShp.CellsU("Height").Result(inch)
htRatio = pgHt / shpHt
If widRatio < htRatio Then
winMag = widRatio * 0.5
Else
winMag = htRatio * 0.5
End If
ActiveWindow.Zoom = winMag
Application.Settings.CenterSelectionOnZoom = False
End Sub