Question

我正在玩Add.Connector（在这里看到另一篇关于此事的帖子，并且对于这可能有什么可能感到好奇）。

我对该主题进行了一些搜索，发现可以使用此方法连接两个形状。但是，我没有找到任何暗示我可以将形状连接到单元格的东西。这甚至可能吗？我怀疑是因为我对这个问题缺乏了解，我无法弄明白。

所以这是一个例子：我有一张看起来像这样的表

这就是我想要实现的目标：

我到目前为止的守则如下：

Sub TestThis()
    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet8")
    Dim oS As Shape
    Dim iC As Long

    For iC = 5 To 7
        Set oS = oWS.Shapes.AddShape(1, 800, iC * 120 - 599, 100, 100)
        oS.Name = "SomeNewShape1"
        oS.TextFrame.Characters.Text = "Playing Connectors " & iC
        oS.TextFrame.Characters.Font.ColorIndex = 1
        oS.Fill.ForeColor.RGB = RGB(227, 214, 213)
    Next

End Sub

如前所述，上面的代码来自我在这里看到的另一篇文章。代码工作正常，如果我想连接到另一个形状，我可以实现。我无法弄清楚的是我将如何连接到一个单元格。任何帮助将不胜感激

Answer 1

单元格没有连接器。如果你肯定想要一个连接器，而不仅仅是一个自由浮动端，那么你可以在单元格上放置一个不可见的形状，如下所示：

Private Function AddInvisibleRectangle(ByVal Target As Range) As Shape

    Dim shpTMP As Shape
    Set shpTMP = Target.Worksheet.Shapes.AddShape(msoShapeRectangle, _
                            Target.Left, Target.Top, Target.Width, Target.Height)

    shpTMP.Fill.Visible = msoFalse
    shpTMP.Line.Visible = msoFalse
    shpTMP.Placement = xlMoveAndSize
    Set AddInvisibleRectangle = shpTMP

End Function

{EDIT} 刚刚进行了一次快速测试，发现了一些有趣的事情 - 如果你通过调整它所穿过的行/列来拉伸形状，这会改变那边的长度连接器已打开，然后连接器无法正常显示，直到您尝试修改它...

Answer 2

如果你＆＃34;欺骗＆＃34;你可以这样做一点：

使用单元格的位置创建一个形状;
连接到该形状
删除形状

-

Option Explicit

Sub TestThis()
    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets(1)
    Dim oS As Shape
    Dim iC As Long
    Dim conn As Shape

    oWS.Cells.Delete

    For iC = 5 To 7
        Set oS = oWS.Shapes.AddShape(1, 800, iC * 120 - 599, 100, 100)
        oS.Name = "SomeNewShape" & iC
        oS.TextFrame.Characters.Text = "Playing Connectors " & iC
        oS.TextFrame.Characters.Font.ColorIndex = 1
        oS.Fill.ForeColor.RGB = RGB(227, 214, 213)
    Next

    Dim cl As Range
    Dim shpOval As Shape
    Dim clLeft&, clTop&, clHeight&, clWidth&

    Set cl = oWS.Range("B1")
    clLeft = cl.Left
    clTop = cl.Top
    clHeight = cl.Height
    clWidth = cl.Width
    Set shpOval = oWS.Shapes.AddShape(msoShapeOval, clLeft, clTop, 4, 10)

    Set conn = oWS.Shapes.AddConnector(1, 1, 1, 1, 1)
    conn.ConnectorFormat.BeginConnect oWS.Shapes("SomeNewShape6"), 1
    conn.ConnectorFormat.EndConnect shpOval, 4
    shpOval.Delete

End Sub

这就是你得到的：

Answer 3

以便其他人在将来看这个，下面是我做的

所以我所做的是在A列中有一个值列表。然后在我的类中运行该函数，它创建的形状与A列中的值一样多，并设置形状名称和文本，因为它在相应的细胞。虚拟形状放置在每个单元格的右上角，以便可以访问单元格。如果更改相应单元格的值，它还会更新形状的名称和文本。这就是它的样子：

这是我的班级：

Private Function AddInvisibleRectangle(ByVal Target As Range) As Shape

    Dim shpTMP As Shape
    Set shpTMP = Target.Worksheet.Shapes.AddShape(msoShapeRectangle, _
                            Target.Left + Target.Width - 2, Target.Top, Target.Width - (Target.Width - 2), (Target.Height / 2) / 2)

    shpTMP.Fill.Visible = msoFalse
    shpTMP.Line.Visible = msoFalse
    shpTMP.Placement = xlMoveAndSize
    shpTMP.Name = Replace(Target.Address, "$", "")
    Set AddInvisibleRectangle = shpTMP

End Function

Sub ShapesAndConnectors()
    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet8")     ' Change to your source sheet
    Dim oS As Shape
    Dim iC&, iFirstR&, iLastR&, iLast&
    Dim oDS As New Scripting.Dictionary
    Dim oI As Variant
    Dim oDummyS As Shape
    Dim oCon As Shape

    iFirstR = oWS.Cells(oWS.Rows.count, 1).End(xlUp).End(xlUp).Row
    iLastR = oWS.Cells(oWS.Rows.count, 1).End(xlUp).Row
    iLast = 5

    For iC = iFirstR To iLastR

        ' Add a shape
        Set oS = oWS.Shapes.AddShape(1, 400, iLast, 100, 40)
        oS.Name = oWS.Range("A" & iC).Value
        oS.TextFrame.Characters.Text = oWS.Range("A" & iC).Value    '"Playing Connectors " & iC
        oS.TextFrame.Characters.Font.ColorIndex = 1
        oS.Fill.ForeColor.RGB = RGB(227, 214, 213)
        iLast = iLast + oS.Height + 10

        ' Add a dummy shape for the cell
        Set oDummyS = AddInvisibleRectangle(oWS.Range("A" & iC))

        ' Add it to dictionary
        oDS.Add oS.Name, oDummyS

    Next

    ' Create connectors
    For iC = 0 To oDS.count - 1
        Set oCon = oWS.Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1)
        oCon.ConnectorFormat.BeginConnect oDS.Items(iC), 1
        oCon.ConnectorFormat.EndConnect oWS.Shapes(oDS.Keys(iC)), 2
        oCon.Line.ForeColor.RGB = RGB(255, 0, 0)
        oCon.Line.EndArrowheadStyle = msoArrowheadTriangle
    Next

End Sub

Sub ClearShapes()
    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet8")
    Dim oS As Shape

    For Each oS In oWS.Shapes
        oS.Delete
    Next
End Sub

Function UpdateShapeText(ByVal sShapeName As String, ByVal sNewText As String) As Boolean
    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet8")
    Dim oS As Shape

    UpdateShapeText = True

    For Each oS In oWS.Shapes
        If LCase(Trim(oS.Name)) = LCase(Trim(sNewText)) Then
            UpdateShapeText = False
            Exit Function
        End If
    Next

    For Each oS In oWS.Shapes
        If oS.Name = sShapeName Then
            oS.Name = sNewText
            oS.TextFrame.Characters.Text = sNewText
            Exit For
        End If
    Next

End Function

我在课堂上有硬编码，但这只是我玩连接器

是否可以使用add.connector连接具有形状的单元格

3 个答案: