好消息是-自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粘到一维形状：False

     

R2连接到0个形状。

     

R2粘贴到一维形状：False

     

R3连接到0个形状。

     

R3粘贴到一维形状：False

     

C1连接到2个形状。

     

C1粘贴为一维形状：False

     

C2连接到2个形状。

     

C2粘贴为一维形状：False

     

C1从C1连接到R1

     

C1从C1连接到R2

     

C2从C2连接到R2

     

C2从C2连接到R3

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

附录：这是我用来遵循箭头的一些旧代码。这是用于创建完整报告的大量代码的一部分，我在此处提供此示例作为如何找到箭头类型的示例。 BPMNShape是一个自定义类，就像我遵循的复杂图表一样-.BaseShape是实际使用的Visio形状。在您的实例中，您可以将其简化为简单的2D形状或关键节点使用的任何母版。 “ IsIntermediate and IsStart”仅确认形状是否基于特定母版。

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

我在下面的功能上使用了“待办事项”（在上面的代码中使用）：添加错误检查并且明智地失败了。

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,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,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,"("))
    End If
    t_string = Replace(t_string,"'","")
    FindShapeName = Trim(t_string)
End Function