Home » excel » excel – Is it possible to connect a cell with a shape using add.connector

excel – Is it possible to connect a cell with a shape using add.connector

Posted by: admin May 14, 2020 Leave a comment

Questions:

I am just playing with Add.Connector (saw another post here about this and was just curious as to what is possible with this).

I did some searches on the subject and found that you can connect two shapes using this method. However, I didn’t find anything that would suggest that I can connect a shape to a cell. Is this even possible? I suspect it is but with my lack of knowledge on the subject, I cannot figure it out.

So here is an example: I have a sheet which looks something like this
enter image description here

This is what I want to achieve:
enter image description here

Code I have so far is as follow:

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

As previously mentioned, the above code is from another post I saw here. Code works fine and if I wanted to connect to another shape, I can achieve that. What I cannot figure out is how I would make the connection to a cell. Any help would be much appreciated

How to&Answers:

You can do this if you “cheat” a bit:

  • create a shape with the position of the cell;
  • connect to that shape
  • delete the shape

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

This is what you get:

enter image description here

Answer:

Cells do not have connectors. If you definitely want a connector, rather than just a free-floating end, then you could put an invisible shape over the cell, like this:

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} Just ran a quick test, and noticed something interesting – if you stretch a shape by resizing a row/column it crosses, and this changes the length of the side that the connector is on, then the connector doesn’t display properly until you try to modify it…

Answer:

Just so that anyone else looking at this in the future, below is what I did

So what I do is have a list of values in column A. I then run the function in my class and it creates as many shapes as I have values in column A and sets the shape name and text as it is in the corresponding cell. Dummy shapes are placed in the top right corner of each cell so that they the cells are accessible. It also updates the name and text of the shape if you change the value of a corresponding cell. This is what it looks like:
enter image description here

And this is my class:

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

I have the sheet hardcoded in the class but this was just me playing with connectors