英文:
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
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库,让每个人都能够通过互相帮助和分享经验来进步。
评论