Visio VBA代码无报错但无执行效果：基于字符串移动图形对象

需求：基于子形状中的特定字符串移动Visio图形对象，编写的VBA代码如下，运行无报错但未执行任何移动操作：

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
Dim Shpname As String

Dim sel As Visio.Selection

For Each vShp In ViPage.Shapes
    For Each subShp In vShp.Shapes
        Select Case subShp
            Case subShp.Characters.Text Like "*AA**"
                ActiveWindow.Select vShp, visSubSelect
                vShp.Cells("PinY").Formula = "80mm"
                vShp.Cells("PinX").Formula = "180mm"
        End Select
    Next subShp
Next vShp

End Sub

问题原因 #

• Select Case语法误用：Select Case的逻辑是匹配表达式的具体值，无法用来判断Like这类条件语句，你的条件永远不会触发。
• 通配符冗余：*AA**中的重复*没有意义，正确的模糊匹配格式应为*AA*（匹配包含"AA"的任意文本）。
• 多余选中操作：修改图形位置无需提前选中形状，ActiveWindow.Select属于冗余操作，甚至可能引入不必要的问题。

解决方法 #

将Select Case替换为If...Then条件判断，修正通配符，并移除冗余操作，优化后的代码如下：

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

    For Each vShp In ViPage.Shapes
        ' 先判断是否有子形状，避免遍历空集合
        If vShp.Shapes.Count > 0 Then
            For Each subShp In vShp.Shapes
                ' 用If判断文本匹配条件
                If subShp.Characters.Text Like "*AA*" Then
                    ' 直接修改图形位置，无需选中
                    vShp.Cells("PinY").Formula = "80mm"
                    vShp.Cells("PinX").Formula = "180mm"
                    ' 找到匹配项后退出内层循环，提升效率
                    Exit For
                End If
            Next subShp
        End If
    Next vShp
End Sub

额外提示：如果目标文本可能存在于主形状而非子形状中，需添加对vShp.Characters.Text的判断；也可以加入Debug.Print subShp.Characters.Text语句，确认是否正确捕获到目标文本。

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