Search code examples
vbavisio

VBA Visio - locate multiple tet-based shapes with the same fill color


As per the discussion in the question here: VBA Visio - locate text-based shapes with the same fill color

I would like to do this exercise in a bunch.

Therefore I've modified the code slightly, which now looks like this:

Sub finalsort4()
Dim vShp As Visio.Shape
Dim isText As Boolean
Dim colorColl As Collection
Dim shpColor As String, shpColor2 As String, shpColor3 As String, shpColor4 As String, 
shpColor5 As String
Dim shpColor6 As String, shpColor7 As String, shpColor8 As String, shpColor9 As String, 
shpColor10 As String
Dim filterColor As String, filterColor2 As String, filterColor3 As String, filterColor4 As 
String, filterColor5 As String
Dim filterColor6 As String, filterColor7 As String, filterColor8 As String, filterColor9 As 
String, filterColor10 As String

Set colorColl = New Collection

'Sort all shapes by fill color and locate "master" shape
For Each vShp In ActiveDocument.Pages("SLD").Shapes
    'Reset Flags
    isText = False
    shpColor = ""
    shpColor2 = ""
    shpColor3 = ""
    shpColor4 = ""
    shpColor5 = ""
    shpColor6 = ""
    shpColor7 = ""
    shpColor8 = ""
    shpColor9 = ""
    shpColor10 = ""
        
    'Extract Shape color and text from subshape
    Call getInfo(vShp, shpColor, isText, "*AA**")
    Call getInfo(vShp, shpColor2, isText, "*AE**")
    Call getInfo(vShp, shpColor3, isText, "*AK**")
    Call getInfo(vShp, shpColor4, isText, "*AR**")
    Call getInfo(vShp, shpColor5, isText, "*AU**")
    Call getInfo(vShp, shpColor6, isText, "*AY**")
    Call getInfo(vShp, shpColor7, isText, "*BC**")
    Call getInfo(vShp, shpColor8, isText, "*BH**")
    Call getInfo(vShp, shpColor9, isText, "*BM**")
    Call getInfo(vShp, shpColor10, isText, "*BS**")
    
    'Group shapes in collections by foreground color formula
    If Not hasKey(colorColl, shpColor) Then colorColl.Add New Collection, shpColor
    colorColl(shpColor).Add vShp
    
    'Set filter color if our shape fulfills the text filter criteria
    If isText Then filterColor = shpColor
    If isText Then filterColor2 = shpColor2
    If isText Then filterColor3 = shpColor3
    If isText Then filterColor4 = shpColor4
    If isText Then filterColor5 = shpColor5
    If isText Then filterColor6 = shpColor6
    If isText Then filterColor7 = shpColor7
    If isText Then filterColor8 = shpColor8
    If isText Then filterColor9 = shpColor9
    If isText Then filterColor10 = shpColor10
  Next vShp

  'Place shapes of desired color at specified location
  For Each vShp In colorColl(filterColor)
    vShp.Cells("PinY") = 32

  Next
  For Each vShp In colorColl(filterColor2)
    vShp.Cells("PinY") = 29

  Next
  For Each vShp In colorColl(filterColor3)
    vShp.Cells("PinY") = 26

  Next
  For Each vShp In colorColl(filterColor4)
    vShp.Cells("PinY") = 23

  Next
  For Each vShp In colorColl(filterColor5)
    vShp.Cells("PinY") = 20

  Next
  For Each vShp In colorColl(filterColor6)
    vShp.Cells("PinY") = 17

  Next
  For Each vShp In colorColl(filterColor7)
    vShp.Cells("PinY") = 14

  Next
  For Each vShp In colorColl(filterColor8)
    vShp.Cells("PinY") = 11

  Next

End Sub

Just part of them moves to the correct position. Is there a way to elaborate this code more nicely?

UPDATE:

Based on the answer below I've tweaked the code, which looks like this:

Sub finalsort6()

Dim filterColors As Collection, colorColl As Collection
Dim textFilter As Collection, textFilters As Collection, isText As 
String
Dim vShp As Visio.Shape

Const Y_OFFSET = 11                'Initial offset for YPin (mm)
Const Y_SPACING = 3                'Spacing between YPin placements (mm)
Set filterColors = New Collection  'Holds the filter shape colors
Set colorColl = New Collection     'Groups shapes by color

 'Create array of text filters to look for (rearrange as necessary for positioning)
 textFilters = Split("AA;AE;AK;AR;AU;AY;BC;BH;BM;BS", ";")

 'Sort all shapes by fill color and locate "master" shape
 For Each vShp In ActiveDocument.Pages("SLD").Shapes
    'Reset Flags
    isText = False
    
    'Extract Shape color and text from subshape, testing for each filter criteria
    For Each textFilter In textFilters
        'Create dynamic pattern to match
        Call GetInfo(vShp, shpColor, isText, "*" & textFilter & "**")

        'Add filter color to list
        If isText Then
            filterColors.Add shpColor, textFilter
            Exit For   'Match found: Exit textFilter loop
        End If
    Next

    'Group shapes in collections by foreground color formula
    If Not hasKey(colorColl, shpColor) Then colorColl.Add New Collection, shpColor
    colorColl(shpColor).Add vShp
  Next vShp


  'Loop over filter shape colors
  For i = 1 To filterColors.Count
    'Place shapes of desired color at specified location
    For Each vShp In colorColl(filterColors(i))
        vShp.Cells("PinY") = Y_OFFSET + (i - 1) * Y_SPACING
    Next
  Next

End Sub

It doesn't work, unfortunately, I am getting the following error:

Argument not optional at the line:

  textFilters = Split("AA;AE;AK;AR;AU;AY;BC;BH;BM;BS", ";")

I feel that I am pretty close to the solution, although I don't know what should be applied here.


Solution

  • Despite my comment on the OP, I've decided to provide an answer anyways. I don't currently have access to Visio and therefore can't test this. I'll leave troubleshooting as an exercise for the OP. A better implementation would be to rewrite getInfo() or to format the Shapes to provide easy access to the filter/grouping criteria, but those aren't part of this question.

    This assumes that each "filter shape" only occurs once.

    Sub finalsort4()
        Const Y_OFFSET = 11                'Initial offset for YPin (mm)
        Const Y_SPACING = 3                'Spacing between YPin placements (mm)
        Set filterColors = New Collection  'Holds the filter shape colors
        Set colorColl = New Collection     'Groups shapes by color
        
        'Create array of text filters to look for (rearrange as necessary for positioning)
        textFilters = Split("AA;AE;AK;AR;AU;AY;BC;BH;BM;BS", ";")
    
        'Sort all shapes by fill color and locate "master" shape
        For Each vShp In ActiveDocument.Pages("SLD").Shapes
            'Reset Flags
            isText = False 
            
            'Extract Shape color and text from subshape, testing for each filter criteria
            For each textFilter in textFilters 
                'Create dynamic pattern to match
                Call getInfo(vShp, shpColor, isText, "*" & textFilter & "**") 
    
                'Add filter color to list 
                If isText then 
                    filterColors.Add shpColor, textFilter
                    Exit For   'Match found: Exit textFilter loop
                End IF 
            Next 
    
            'Group shapes in collections by foreground color formula
            If Not hasKey(colorColl, shpColor) Then colorColl.Add New Collection, shpColor
            colorColl(shpColor).Add vShp    
        Next vShp
    
    
        'Loop over filter shape colors
        For i = 1 to filterColors.Count   
            'Place shapes of desired color at specified location                                     
            For Each vShp In colorColl(filterColors(i))                        
                vShp.Cells("PinY") = Y_OFFSET + (i-1) * Y_SPACING              
            Next
        Next
    
    End Sub