How to link existing shapes in excel with a straight line using VBA dynamically

问题

i've 4 rounded rectangular shapes in "sheet1" of a workbook, now i want to link them with their shape names. The shape names will be in column A of another sheet, the names in the column and the names in the text frame of shape will be same, so i need to link them using VBA code, i am a beginner in VBA, i've tried some code but stuck in between, can anyone help me out to solve my problem.

Sub ConnectingShapes()
Dim ws As Worksheet
Dim txBox As Shape
Dim sTemp As String
On Error Resume Next
Set myDocument = Worksheets(1)
Set s = myDocument.Shapes
i = 2
For Each shp In s.Shapes
'With myDocument.Shapes.AddLine(10, 10, 250, 250).Line
    '.DashStyle = msoLineDashDotDot
    '.ForeColor.RGB = RGB(50, 0, 128)
'End With
'sTemp = shp.Name
txBox = shp.Name
If shp.Name = sTemp Then
Set c = s.AddConnector(msoConnectorCurve, 0, 0, 100, 100)
With c.ConnectorFormat
    .BeginConnect ConnectedShape:=txBox, ConnectionSite:=1
    .EndConnect ConnectedShape:=Cells(i , 9), ConnectionSite:=1
     c.RerouteConnections
End With
i = i + 2
Else
MsgBox ("Nothing Found")
End If`enter code here`
Next
End Sub

回答1:

This may be a good starting point. You can copy this in a module; all info are in Sheet1:

Option Explicit

Sub ConnectingShapes()
    Dim WS As Worksheet
    Set WS = ThisWorkbook.Worksheets(1)

    Dim lastRow As Long
    lastRow = WS.Range("a" & WS.Rows.Count).End(xlUp).Row

    Dim Shp1 As Shape, Shp2 As Shape, Conn As Shape
    Dim i As Long
    Dim rowOffSet As Long: rowOffSet = 1
    For i = 1 To lastRow
        Set Shp1 = GetTxtBoxShapeByContent(WS.Cells(i, 1).Value, WS)
        If i = lastRow Then 'To check if we have to come back to beginning
            rowOffSet = -lastRow + 1
        End If
        Set Shp2 = GetTxtBoxShapeByContent(WS.Cells(i, 1).Offset(rowOffSet, 0).Value, WS)

        Set Conn = WS.Shapes.AddConnector(msoConnectorStraight, 0, 100, 0, 100)
        With Conn.ConnectorFormat
            .BeginConnect Shp1, 1
            .EndConnect Shp2, 1
        End With
        Conn.RerouteConnections
        Set Conn = Nothing
    Next i
End Sub

'Function that gets the wanted txtbox by its content
Function GetTxtBoxShapeByContent(iTxtBoxVal As String, WS As Worksheet) As Shape
    Dim Shp As Shape
    For Each Shp In WS.Shapes
        If Shp.TextFrame.Characters.Text = iTxtBoxVal Then
            Set GetTxtBoxShapeByContent = Shp
            Exit Function
        End If
    Next Shp
End Function

Before running the macro:

Result:

来源：https://stackoverflow.com/questions/21022636/how-to-link-existing-shapes-in-excel-with-a-straight-line-using-vba-dynamically

标签

excel-vba

vba

excel