Visio VBA技术求助：按文本后缀+填充色筛选并排列形状

问题背景 #

• 已实现单独按文本后缀（如AA、AB）或填充色筛选并移动Visio形状，但需要同时结合两者筛选：先定位文本后缀为AA的形状，再筛选所有与其填充色相同的元素
• 自行编写的finalsort代码因未初始化对象报错：Object variable or with variable not set
• 最终需求：将同填充色的元素排列到同一行，并按字母顺序排序

解决方案 #

1. 筛选与后缀AA形状同填充色的元素 #

先获取任意一个后缀为AA的形状的填充色公式，再遍历所有形状（含子形状）匹配该颜色。核心注意点：

• 必须先为对象赋值后再访问其属性，避免未初始化报错
• Visio填充色公式常包含THEMEGUARD，直接对比FormulaU值即可精准匹配颜色

2. 排列到同一行并按字母排序 #

执行步骤：

1. 收集所有符合颜色条件的父形状
2. 按形状的文本内容进行字母顺序排序
3. 统一设置所有形状的PinY值，使其处于同一行
4. 依次设置PinX值，让形状按排序结果横向排列

完整修正代码 #

Sub FinalSort_AA_SameColor()
    Dim DiagramServices As Integer
    DiagramServices = ActiveDocument.DiagramServicesEnabled
    Dim ViPage As Page
    Set ViPage = ActiveDocument.Pages("SLD")
    
    Dim targetColorFormula As String
    Dim vShp As Visio.Shape, subShp As Visio.Shape
    Dim shapeList As Collection
    Dim sortedShapes() As Visio.Shape
    Dim i As Integer, j As Integer
    Dim tempShp As Visio.Shape
    Dim baseX As Double, spacingX As Double, targetY As Double
    
    ' --- 第一步：获取AA后缀形状的填充色公式 ---
    targetColorFormula = ""
    For Each vShp In ViPage.Shapes
        For Each subShp In vShp.Shapes
            ' 精准匹配文本后缀为AA的子形状
            If subShp.Characters.Text Like "*AA" Then
                targetColorFormula = subShp.CellsU("FillForegnd").FormulaU
                Exit For ' 找到目标后停止遍历，取第一个匹配形状的颜色
            End If
        Next subShp
        If targetColorFormula <> "" Then Exit For
    Next vShp
    
    ' 未找到AA后缀形状时直接退出
    If targetColorFormula = "" Then
        MsgBox "未找到文本后缀为AA的形状"
        Exit Sub
    End If
    
    ' --- 第二步：收集所有同填充色的父形状 ---
    Set shapeList = New Collection
    For Each vShp In ViPage.Shapes
        For Each subShp In vShp.Shapes
            ' 匹配填充色，且避免重复添加同一父形状
            If subShp.CellsU("FillForegnd").FormulaU = targetColorFormula Then
                On Error Resume Next
                shapeList.Add vShp, Key:=CStr(vShp.ID)
                On Error GoTo 0
            End If
        Next subShp
    Next vShp
    
    ' --- 第三步：按文本字母顺序排序形状 ---
    ReDim sortedShapes(1 To shapeList.Count)
    For i = 1 To shapeList.Count
        sortedShapes(i) = shapeList(i)
    Next i
    
    ' 冒泡排序：按形状主文本的字母顺序排列
    For i = 1 To UBound(sortedShapes) - 1
        For j = i + 1 To UBound(sortedShapes)
            If sortedShapes(i).Characters.Text > sortedShapes(j).Characters.Text Then
                Set tempShp = sortedShapes(i)
                Set sortedShapes(i) = sortedShapes(j)
                Set sortedShapes(j) = tempShp
            End If
        Next j
    Next i
    
    ' --- 第四步：排列到同一行并横向分布 ---
    targetY = 780 ' 目标行Y坐标（单位：mm）
    baseX = 180 ' 起始X坐标
    spacingX = 70 ' 形状横向间距
    
    For i = 1 To UBound(sortedShapes)
        With sortedShapes(i)
            .Cells("PinY").Formula = targetY & "mm"
            .Cells("PinX").Formula = (baseX + (i - 1) * spacingX) & "mm"
        End With
    Next i
    
    ' 恢复DiagramServices设置
    ActiveDocument.DiagramServicesEnabled = DiagramServices
End Sub

代码说明 #

• 修复了原代码中对象未初始化的错误，先定位AA后缀形状再获取目标颜色
• 使用Collection收集形状，避免重复操作同一父形状
• 可通过修改targetY、baseX、spacingX参数调整排列位置和间距
• 排序依据可按需修改（比如改为子形状的文本内容）

内容的提问来源于stack exchange，提问作者Geographos