Add connector to two existing shapes with VBA

[D Coker]

I am trying to get this existing code changed to where each rectangle shape and text box are connected by a connector automatically as it loops through a list of data- without losing any attributes to the rectangle or text box. Any help is appreciated!

  'Add Rectangle
  Dim plotwrap As Boolean
 
  plotwrap = True 'True allows Vertical Wrap, False stops Vertical Wrap
 
  If plotwrap And (Sht + shh) > (pt + ph) Then
      'plot bottom of Rectangle
      ActiveSheet.Shapes.AddShape(msoShapeRectangle, shl, Sht, shw, pt + ph - Sht).Select
      'Color Bottom half of Rectangle
      Call ColorShape(mycolor, DrawOutLine)
    '  MsgBox ("Circ Start: " & sht)
      'plot top of Rectangle
      Application.CutCopyMode = False
      ActiveSheet.Shapes.AddShape(msoShapeRectangle, shl, pt, shw, shh - (pt + ph - Sht)).Select
      'MsgBox (sht)
  Else
      ActiveSheet.Shapes.AddShape(msoShapeRectangle, shl, Sht, shw, shh).Select
      'MsgBox (sht)
  End If
    
  'Color Rectangle
  Call ColorShape(mycolor, DrawOutLine)
    
  'Add text box
  Dim sht_Offset As Double
  sht_Offset = 15 'Offset from top of Rectangle

ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, shl, Sht - sht_Offset, shw, 20).Select
  With Selection.ShapeRange.TextFrame2
    .VerticalAnchor = msoAnchorMiddle
    .MarginLeft = 0
    .MarginRight = 0
    .MarginTop = 0
    .MarginBottom = 0
    .WordWrap = False
    .AutoSize = msoAutoSizeShapeToFitText
    .TextRange.Characters.Text = onm
  End With
 
  Selection.ShapeRange.Line.Visible = msoFalse 'Plot Textbox border
  Selection.ShapeRange.Fill.Visible = msoFalse
 
  With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, Len(onm)).ParagraphFormat
    .FirstLineIndent = 0
    .Alignment = msoAlignLeft ' Change Text alignment here
  End With
  With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, Len(onm)).Font
    .NameComplexScript = "+mn-cs"
    .NameFarEast = "+mn-ea"
    .Size = 8 'Text size
    .Name = "+mn-lt"
  End With
  
Next i

'Bring all Textboxes to Front

Dim oTextBox As TextBox

For Each oTextBox In ActiveSheet.TextBoxes
  If Left(oTextBox.Name, 4) = "Rect" Then
    oTextBox.Select
    Selection.ShapeRange.ZOrder msoBringToFront
    Selection.ShapeRange.Fill.Visible = msoCTrue
  End If
Next oTextBox

Range("J11").Select

eh:

Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub


Function ColorShape(ByVal mycolor As Double, DrawOutLine As Boolean)
  With Selection.ShapeRange.Fill
      .Visible = msoTrue
      .ForeColor.RGB = mycolor
      .Transparency = 0.25
      .Solid
  End With
    
  If DrawOutLine Then
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.Weight = 0.5
    Selection.ShapeRange.Line.DashStyle = msoLineRoundDot
    
  Else
    Selection.ShapeRange.Line.Visible = msoFalse
  End If
End Function

 

[Hui]

Can you please attach a sample file with some data and shapes?

 

[D Coker]

Thanks for the reply Hui! I think I got it.

Let me know if I could improve the sample code below, but right now it seems to work as intended.

I was able to figure it out by setting the shape after the attributes were populated by using code similar to this:

't3 is a sample of one shape
't3 attributes assigned here - CODE DELETED FOR EASIER VIEWING

 Set t3 = ActiveSheet.Shapes(Selection.Name)

's3 is a sample of one shape
's3 attributes assigned here - CODE DELETED FOR EASIER VIEWING

Set s3 = ActiveSheet.Shapes(Selection.Name)

'Create connector
  Set conn3 = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 0, 0, 0, 0)
'Connect shapes
    conn3.ConnectorFormat.BeginConnect s3, 1
    conn3.ConnectorFormat.EndConnect t3, 1
    conn3.Line.ForeColor.RGB = RGB(128, 128, 128)
 ' Connect via shortest path (changes connection sites)
    conn3.RerouteConnections