VBA Visio – 定位具有相同填充颜色的多个基于文本的形状

huangapple
go评论59阅读模式
英文:

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

问题

I see the issue in your code. It seems like you're missing the declaration for the shpColor variable. You need to declare it before using it in the loop. Here's the corrected part of your code:

Sub finalsort6()
    Dim filterColors As Collection, colorColl As Collection
    Dim textFilters As Variant, isText As String
    Dim vShp As Visio.Shape
    Dim shpColor As String ' Declare shpColor here

    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", ";")

    ' Rest of your code...
End Sub

By declaring shpColor before using it, the error should be resolved. Make sure you also declare other variables you might be using in the code.

英文:

As per the discussion in the question here:
https://stackoverflow.com/questions/76424249/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.

答案1

得分: 2

尽管我对 OP 的评论进行了回应，但我还是决定提供答案。目前我无法访问 Visio，因此无法测试这个。我会留下故障排除作为 OP 的练习。更好的实现方式是重写 getInfo() 或格式化 Shapes 以提供对过滤/分组标准的轻松访问，但这些不属于这个问题的一部分。

这假设每个“过滤形状”只会出现一次。

英文:

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

huangapple
  • 本文由 发表于 2023年6月15日 16:23:29
  • 转载请务必保留本文链接：https://go.coder-hub.com/76480508.html
  • vba
  • visio
匿名

发表评论

匿名网友

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen:

确定