VBA Excel 中连接形状的识别

Question

我正在尝试在 Excel 中开发一个 VBA 解决方案，它可以识别工作表中哪些形状通过标准连接线相互连接。

例如，在附加的代码片段中，我需要创建一个代码来识别控制方块连接到两个红色圆圈（标题为 Risk 1 和 Risk 2），并在消息框中输出以下内容： “风险 1 和风险 2 与控制相关联”。我已经能够找到添加连接线的代码，但是我无法弄清楚如何识别连接的形状。任何指导将不胜感激！我还附上了到目前为止我能够找到的代码。

Sub QuickConnect( )
    Dim s1 As Shape, s2 As Shape, conn As Shape
    
    ' Create a shape
    Set s1 = ActiveSheet.Shapes.AddShape(msoShapeCube, 100, 10, 50, 60)
    
    ' Create another shape
    Set s2 = ActiveSheet.Shapes.AddShape(msoShapeCan, 50, 100, 50, 60)

    ' Create connector with arbitrary coordinates
    Set conn = ActiveSheet.Shapes.AddConnector(msoConnectorCurve, 1, 1, 1, 1)

    ' Connect shapes
    conn.ConnectorFormat.BeginConnect s1, 1
    conn.ConnectorFormat.EndConnect s2, 1
    
    ' Connect via shortest path (changes connection sites)
    conn.RerouteConnections
End Sub

Answer 1

因此您需要遍历所有形状，检查它们是否是连接器（是的，连接线也是形状）。然后你可以检查这个连接线连接了哪些形状：

属性 .ConnectorFormat.BeginConnectedShape 给出连接线一端的形状，.ConnectorFormat.EndConnectedShape 给出另一端的形状。

检查这个：

Option Explicit

Public Sub TestConnections()
    Dim shp As Variant
    For Each shp In Shapes 'loop through all shapes            
        If shp.Connector = msoTrue Then 'check if current shape is a connector
            'BeginConnectedShape is the shape on the beginning side of the connector
            'EndConnectedShape is the shape on the ending side of the connector
            Debug.Print shp.Name _
                        & " connects " & _
                        shp.ConnectorFormat.BeginConnectedShape.Name _
                        & " with " & _
                        shp.ConnectorFormat.EndConnectedShape.Name
        End If
    Next shp 
End Sub

对于以下形状

它输出

Curved Connector 3 connects Cube 1 with Can 2
Curved Connector 6 connects Cube 5 with Can 2

Answer 2

您可以使用ConnectorFormat.EndConnectedShape property (Excel) and ConnectorFormat.BeginConnectedShape property (Excel)来实现您想要的。

逻辑：

遍历所有连接器形状。
创建一个独特的形状集合，其他形状与之相连。
获取开始和结束形状名称。
找到关系，即 WHO 与 WHO 相关联。

代码：

我已经对代码进行了评论，但如果您仍有疑问，请随时提问。

Option Explicit

'~~> Change this if your shapes include the below text
Const mySep As String = "MySep"

Sub Sample()
    Dim ws As Worksheet
    Dim shpConnector As Shape
    Dim shpConnectorCount As Long
    Dim i As Long: i = 1
    Dim tmpAr As Variant, itm As Variant
    Dim colConnector As New Collection
    Dim msg As String
    Dim finalOutput As String
    
    '~~> Change this to the relevant sheet
    Set ws = Sheet1
    
    With ws
        '~~> Count the number of connector shapes
        For Each shpConnector In .Shapes
            If shpConnector.Connector Then shpConnectorCount = shpConnectorCount + 1
        Next shpConnector
        
        '~~> If not found then exit sub
        If shpConnectorCount = 0 Then Exit Sub
        
        '~~> Resize array based on connector count
        ReDim tmpAr(1 To shpConnectorCount)
        
        For Each shpConnector In .Shapes
            With shpConnector
                If .Connector Then
                    '~~> Unique collection of shapes to which other
                    '~~> shapes are connected with
                    On Error Resume Next
                    colConnector.Add CStr(.ConnectorFormat.EndConnectedShape.Name), _
                    CStr(.ConnectorFormat.EndConnectedShape.Name)
                    On Error GoTo 0
                    
                    '~~> Store Starting shape and End Shape in an array
                    tmpAr(i) = .ConnectorFormat.BeginConnectedShape.Name & mySep _
                    & .ConnectorFormat.EndConnectedShape.Name
                    i = i + 1
                End If
            End With
        Next
        
        '~~> Loop through the unique collection and the array to create
        '~~> Our necessary output
        For Each itm In colConnector
            msg = ""
            For i = LBound(tmpAr) To UBound(tmpAr)
                If Split(tmpAr(i), mySep)(1) = itm Then
                    msg = msg & "," & Split(tmpAr(i), mySep)(0)
                End If
            Next i
            finalOutput = finalOutput & vbNewLine & Mid(msg, 2) & " is/are connected to " & itm
        Next itm
    End With
    
    MsgBox Mid(finalOutput, 2)
End Sub

进行中：

屏幕截图：

VBA Excel 中连接形状的识别

VBA Identification of Connected Shapes in Excel

excel

vba

shapes