VBA 获取形状信息（Visio 2007 流程图）

Question

所有，我一直在谷歌搜索无济于事。我在 Excel 和 Word 中的 VBA 相当不错，但 Visio 对我来说很新。

背景：某人（已离开公司）创建了一个非常漂亮的 Visio 流程图。 注意：在我们公司，我们仅限于 Visio 2007。 我需要做的是获取每个形状中文本的简单列表按照形状在流程中出现的顺序。 （还需要形状颜色信息，原因不值得一提。）我需要将其显示为非 Visio 格式的列表（例如幻灯片）。

所以我首先尝试了下面的代码，以为我可以为此使用索引号——但结果发现流程图作者卡在了一些形状（框）中。所以我想也许根据 X 和 Y 坐标进行排序会有所帮助——而且更好，除了一些框在 Y 轴上比它们的前任/父框高一点，所以这不起作用。

我确信有更好的方法来完成一项简单的任务，但我一生都找不到它。我认为必须可以执行以下操作：从形状 1（获取形状文本）开始，连接到形状 2（获取形状文本），依此类推……谁能指出我正确的方向？

提前致谢

Sub list_shapes()
Dim sh As Shape
For Each sh In ThisDocument.Pages(2).Shapes
   Debug.Print n; "text= "; sh.Text; "shapename= "; sh.Name; "index= "; sh.Index; "shapetype= "; sh.Type; "x-coordinate="; sh.Cells("PinX"); "y-coordinate="; sh.Cells("PinY"); "[shapecolor="; sh.Cells("Fillforegnd")
Next
End Sub

Answer 1

好消息是 - 从 Visio 2010 开始，使用ConnectedShapes() 方法就有了一种简单的方法来执行此操作。坏消息是您只能使用 Visio 2007。

我将举例说明。

在下面的代码中，我还包含了一些较旧的属性。 2010 年之前，该方法是识别所有连接器并通过识别连接的形状和还识别箭头的存在（或不存在）来构建地图。乏味但可行。一旦你设置了代码，它就可以被重复使用，所以在编码前面的少量痛苦将有助于你在更长期的报告中。

输出基于第 1 页上的以下图像。

Private Sub ConnectionThings()

Dim testShape As Shape
Dim testPage As Page
    Set testPage = ThisDocument.Pages(1)

Dim testArray() As Long
Dim iterator As Long

    For Each testShape In testPage.Shapes
        If Not testShape.OneD Then
            testArray = testShape.ConnectedShapes(visConnectedShapesIncomingNodes, "")
            For iterator = LBound(testArray) To UBound(testArray)
                Debug.Print testShape.Text & " is connected to " & testPage.Shapes(testArray(iterator)).Text & " (incoming)."
            Next iterator
            testArray = testShape.ConnectedShapes(visConnectedShapesOutgoingNodes, "")
            For iterator = LBound(testArray) To UBound(testArray)
                Debug.Print testShape.Text & " is connected to " & testPage.Shapes(testArray(iterator)).Text & " (outgoing)."
            Next iterator
        End If
    Next testShape

        Debug.Print vbCrLf & "*** Demonstration of older properties *** "

    For Each testShape In testPage.Shapes
        Debug.Print testShape.Text & " is connected to " & testShape.Connects.Count & " shape(s)."
        Debug.Print testShape.Text & " is glued to " & " 1D shape(s): " & IsEmpty(testShape.GluedShapes(visGluedShapesAll1D, ""))
    Next testShape

Dim testConnectedShape As Shape
Dim testConnection As Connect
    For Each testShape In testPage.Shapes
        For Each testConnection In testShape.Connects
            Debug.Print testShape.Text & " is connected from " & testConnection.FromSheet.Text & " to " & testConnection.ToSheet.Text
        Next testConnection
    Next testShape
End Sub

R1 连接到 R2（传出）。

R2 连接到 R1（传入）。

R2 连接到 R3（传出）。

R3 连接到 R2（传入）。

* 旧属性演示 *

R1 连接到 0 个形状。

R1 被粘到一维形状上：错误

R2 连接到 0 个形状。

R2 被粘到一维形状上：错误

R3 连接到 0 个形状。

R3 被粘在一维形状上：错误

C1 连接到 2 个形状。

C1 被粘到一维形状上：错误

C2 连接到 2 个形状。

C2 被粘到一维形状上：错误

C1 从 C1 连接到 R1

C1 从 C1 连接到 R2

C2 从 C2 连接到 R2

C2 从 C2 连接到 R3

** 也许您可以说服您的公司允许使用 Visio 2010 或更高版本？毕竟，2007 年已经过去了十多年，而且已经失去支持。甚至 2010 年也将失去支持。我的代码是在 Visio 2019 或 365 中开发的（不确定是哪个，找不到版本号）。

附录：这是我用来跟随箭头的一些旧代码。这是用于创建完整报告的大量代码的一部分，我在此提供此作为如何查找箭头类型的示例。 BPMNShape 是一个自定义类，因为我正在关注一个复杂的图表 - .BaseShape 是实际使用的 Visio 形状。在您的实例中，您可以将其简化为简单的二维形状或关键节点正在使用的任何主节点。 'IsIntermediateandIsStart` 仅确认形状是否基于特定母版。

Private Function FindNextNonFlow2(ThePage As Page, TheShape As BPMNShape) As BPMNShape
' TheShape must be an intermediate or start
Dim t_Connect As Connect
Dim t_shape As New BPMNShape
Dim t_shape2 As New BPMNShape
Dim t_shape3 As New BPMNShape

    Set t_shape.BaseShape = TheShape.BaseShape
    If t_shape.IsSequence Then
        If t_shape.ArrowCodeEnd = 13 Then
            Set t_shape.BaseShape = ThePage.Shapes(t_shape.TriggerShapeEnd)
        Else
            Set t_shape.BaseShape = ThePage.Shapes(t_shape.TriggerShapeBegin)
        End If
    End If
    If t_shape.IsIntermediate Or t_shape.IsStart Then
        ' Code here
        ' use FromConnects
        ' End arrow = 13
        For Each t_Connect In t_shape.FromConnects
            Set t_shape2.BaseShape = t_Connect.FromSheet
            If t_shape2.IsSequence Then
                If t_shape2.ArrowCodeEnd = 13 And Not (ThePage.Shapes(t_shape2.TriggerShapeEnd) = t_shape.BaseShape) Then
                    Set t_shape3.BaseShape = ThePage.Shapes(t_shape2.TriggerShapeEnd)
                ElseIf t_shape2.ArrowCodeBegin = 13 And Not (ThePage.Shapes(t_shape2.TriggerShapeBegin) = t_shape.BaseShape) Then
                    Set t_shape3.BaseShape = ThePage.Shapes(t_shape2.TriggerShapeBegin)
                End If
            End If
        Next t_Connect
        If t_shape3.IsNotNothing Then Set t_shape = t_shape3
    End If
    Set FindNextNonFlow2 = t_shape
End Function

我在下面的函数上有一个“TO-DO”（在上面的代码中使用）：添加错误检查和明智的失败。

Property Get ArrowCodeBegin() As Double
    ArrowCodeBegin = p_TheShape.CellsSRC(visSectionObject, visRowLine, visLineBeginArrow).Result(visNoCast)
End Property

Property Get ArrowCodeEnd() As Double
    ArrowCodeEnd = p_TheShape.CellsSRC(visSectionObject, visRowLine, visLineEndArrow).Result(visNoCast)
End Property

Property Get TriggerShapeEnd() As String
    TriggerShapeEnd = FindShapeName( _
                        p_TheShape.CellsSRC(visSectionObject, visRowMisc, visEndTrigger).Formula)
    'If p_TheShape Is Nothing Then Debug.Print "Issue: trid an operation on a null shape"
End Property

Property Get TriggerShapeBegin() As String
    TriggerShapeBegin = FindShapeName( _
                        p_TheShape.CellsSRC(visSectionObject, visRowMisc, visBegTrigger).Formula)
End Property

Private Function FindShapeName(TheTriggerString As String) As String
Dim t_string As String
    t_string = TheTriggerString
    If Len(t_string) > 0 Then
        t_string = Left(t_string, InStr(1, t_string, "!") - 1)
        t_string = Right(t_string, Len(t_string) - InStr(1, t_string, "("))
    End If
    t_string = Replace(t_string, "'", "")
    FindShapeName = Trim(t_string)
End Function