vbavisio

VBA Visio - locate text-based shapes with the same fill color

I have managed to select the objects by their fill color as well as the text. However, my major goal is to select them both by text and color simultaneously. I have a situation as you can see below:

enter image description here

I used the following code to place two elements with the text end AA and AB

Sub textsort()
Dim DiagramServices As Integer
DiagramServices = ActiveDocument.DiagramServicesEnabled
Dim ViPage As Page
Set ViPage = ActiveDocument.Pages("SLD")
Dim vShp As Visio.Shape
Dim subShp As Visio.Shape

Dim sel As Visio.Selection

For Each vShp In ViPage.Shapes
For Each subShp In vShp.Shapes
Select Case True
Case subShp.Characters.Text Like "*AA**"
ActiveWindow.Select vShp, visSubSelect
vShp.Cells("PinY").Formula = "780mm"
vShp.Cells("PinX").Formula = "180mm"
' iterate other conditions
Case subShp.Characters.Text Like "*AB**"
ActiveWindow.Select vShp, visSubSelect
vShp.Cells("PinY").Formula = "780mm"
vShp.Cells("PinX").Formula = "250mm"

End Select

Next subShp
Next vShp

End Sub

but I would like to have all of the elements, which have the same color filled exactly in one row.

I could use the formula like this:

 If subShp.CellsU("FillForegnd").FormulaU = "THEMEGUARD(RGB(0,0,255))" Then    'BLUE
            ActiveWindow.Select vShp, visSubSelect
            Debug.Print vShp.ID & " - " & vShp.Master.Name
            ActiveWindow.Selection.Align visHorzAlignNone, visVertAlignTop, False
            vShp.Cells("PinY").Formula = "830mm"
            ActiveWindow.DeselectAll
End If

which brings all the elements to one row located at Y=830mm, but the problem is, that I need the elements sorted alphabetically. Therefore I though, that catching the value with the text ending at AA (the very first from the left) would help me to achieve this goal since I know how to move all of them to the same row.

I've raised this question here: VBA Visio - autoorder items by their value (alphabetically)

What I exactly need is:

Since I know, that every single shape includes the color value based within the THEMEGUARD() value like below:

 CellsU("FillForegnd").FormulaU = "THEMEGUARD(RGB())

I would assume something like this: If the shape with text ends at AA then:

For this reason I found some approach here: http://visguy.com/vgforum/index.php?topic=4279.0

And prepare the code, which potentially could be useful:

Sub finalsort()
Dim DiagramServices As Integer
DiagramServices = ActiveDocument.DiagramServicesEnabled
Dim ViPage As Page
Set ViPage = ActiveDocument.Pages("SLD")
Dim vShp As Visio.Shape
Dim subShp As Visio.Shape, shpObj As Visio.Shape
Dim fcCell As Visio.Cell

Dim sel As Visio.Selection

Set fcCell = shpObj.Cells("FillForegnd")
For Each vShp In ViPage.Shapes
For Each subShp In vShp.Shapes
Select Case True
Case subShp.Characters.Text Like "*AA**"
ActiveWindow.Select vShp, visSubSelect
vShp.Cells("PinY").Formula = "780mm"
vShp.Cells("PinX").Formula = "180mm"
If subShp.fcCell > 1 Then
subShp.Cells("PinY").Formula = "780mm"
End If
End Select

Next subShp
Next vShp

End Sub

but it returns an error at the line:

Set fcCell = shpObj.Cells("FillForegnd")

Object variable or with variable not set

Anyway I am not sure it is correct, but as far as I understand the set above picks up the same FillForegnd parameters, so if it's > 1 then it means that there are other objects, which have the same color fill.

Concluding I am asking:

Solution

  • After looking through several of your recent posts, I think what @Surrogate was trying to say in the OP comments was to define all of your sorting criteria into the parent (top-level) shapes instead of having to loop through sub-shapes all the time. In the parent ShapeSheet, you could define some ShapeData like

    Prop.DisplayText = "NRTH-X-AF01AL"
Prop.FillColor = "THEMEGUARD(RGB(0,0,255))"

    Then have the appropriate subshape cells reference those (if you want the ShapeData to display as Shape text you'll need to Insert a Text Field). Depending on your actual use, you could even perform your filter criteria directly in the parent Shape and stored in something like User.PickMe to be easily accessed via VBA!

    Anyways, back to what you're asking. The Cell object refers to a specific ShapeSheet cell for a particular shape. Because shpObj isn't set, it doesn't have a ShapeSheet and its FillForegnd cell cannot be accessed. That's what's causing the described error. On top of that, to my knowledge, Select Case doesn't work well with the Like operator. Since you only have one case, this can be replaced by an If...Then... and save some space.

    With a little refactoring, here's some code that should run properly based on your existing code.

    UPDATE: Code has been updated based on discussion in comments. I originally thought that we were selecting shapes based on text and color, but instead we're locating a designator shape by its text and then using its fill to filter the others.

    Sub finalsort()
    Dim vShp As Visio.Shape
    Dim isText As Boolean
    Dim colorColl As Collection
    Dim shpColor As String, filterColor 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 = ""
            
        'Extract Shape color and text from subshape
        Call getInfo(vShp, shpColor, isText, "*AA**")
        
        '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
    Next vShp
    
    'Place shapes of desired color at specified location
    For Each vShp In colorColl(filterColor)
        vShp.Cells("PinY") = 8
        vShp.Cells("PinX") = 3
    Next
    
End Sub

Sub getInfo(shp As Shape, ByRef shpColor As String, ByRef isText As Boolean, textFilter As String)
'''Loops through subshapes, extracting relevant info. Assigns shpColor and isText as return values
    Dim subShp As Visio.Shape
    For Each subShp In shp.Shapes
        'Filter by text
        If subShp.Characters.Text Like textFilter Then isText = True
        
        'Store color (ASSUMES ONLY 1 SUBSHAPE HAS A COLOR FILL USING RGB()!)
        If subShp.Cells("FillForegnd").FormulaU Like "*RGB*" Then shpColor = subShp.Cells("FillForegnd").FormulaU
    Next
End Sub

Function hasKey(coll As Collection, key As String) As Boolean
'''Uses error handling to determine if Collection key exists. Using a dict would be better
    Dim var As Variant
    
    'Enable Error Handling to catch "Key Not Found" error. DISABLE IF ERRORS ARE HAPPENING
    On Error Resume Next
    
    'Catch errors resulting from accessing key. If error occurs, key doesn't exist
    Set var = coll(key)
    hasKey = (Err.Number = 0)
    Err.Clear
End Function

    Note: The above code places every accepted shape at the same location and doesn't sort by text. You asked how to do those things in other questions, but my advice would be to store all of them in a Collection, sorting as you go, and then using the index as a modifier when moving the shape to properly offset them. Even after reading your post(s) several times and examining the provided image, I'm still not completely sure what you're trying to do.