Add a textbox below a shape

[ifu06416]

Hi there,

I'm looking to add a text box just below a shape. The textbox would be populated with the string found in cell c5.

The code i have for generating the shape is as follows;

Sub DANS()


    Dim ws As Worksheet
    Dim Start_Diamond As Shape
    Dim End_Diamond As Shape
    Dim conn As Shape
    Dim Start_Range As Range
    Dim End_Range As Range
    Dim Start_Pos As Single
    Dim End_Pos As Single
  '  Dim Caption As TextBox
    
    On Error GoTo errorHandler
    
    'set reference to a worksheet
    Set ws = ActiveSheet
    
    
''''''''''''''''''''''''''''''''''''Task 1'''''''''''''''''''''''''''''''''''''''
    'find start and end ranges
    With Application
        Set Start_Range = .Index(ws.Range("F5:BM5"), .Match(Format(ws.Range("D5").Value, "mmm"), ws.Range("F4:BM4"), 0))
        Set End_Range = .Index(ws.Range("F5:BM5"), .Match(Format(ws.Range("E5").Value, "mmm"), ws.Range("F4:BM4"), 0))
        
    End With
    
    'find start position
    With Start_Range
        Start_Pos = .Left + (.Width / 2) - (8.5 / 2)
    End With
    
    'find end position
    With End_Range
        End_Pos = .Left + (.Width / 2) - (8.5 / 2)
    End With
    
    'add Start Diamond
     Set Start_Diamond = ws.Shapes.AddShape(msoShapeDiamond, Start_Pos, Start_Range.Top + 2, 8.5, 9.6)

    
     'add End Diamond
     Set End_Diamond = ws.Shapes.AddShape(msoShapeDiamond, End_Pos, End_Range.Top + 2, 8.5, 9.6)
    
    'Set the connector link
    Set conn = ws.Shapes.AddConnector(msoConnectorStraight, 15, 150, 15, 150)
    
    conn.ConnectorFormat.BeginConnect Start_Diamond, 1
    conn.ConnectorFormat.EndConnect End_Diamond, 1
    conn.RerouteConnections

exitHandler:
    Exit Sub
    
errorHandler:
    MsgBox "Error " & Err.Number & ":  " & Err.Description, vbCritical, "Error"
    Resume exitHandler   

End Sub

and the spreadsheet layout is as follows ;

I'm not certain how to change this code to have a text box generated at the same time as the shape.

Regards,

John

 

[Domenic]

After your code creates the diamond shapes and connector, you can add the following lines to your code. Change the width and height as desired.

    ws.Shapes.AddTextbox msoTextOrientationHorizontal, Start_Diamond.Left, Start_Diamond.Top + 15, 75, 20
   
    ws.Shapes.AddTextbox msoTextOrientationHorizontal, End_Diamond.Left, End_Diamond.Top + 15, 75, 20

By the way, when I provided you with the code in a previous thread, I didn't know that each month contained 5 columns. So if you want the ending diamond positioned in the 5th column instead of the 1st, use the following code instead . . .

    'find end position
    With End_Range.Offset(, 4)
        End_Pos = .Left + (.Width / 2) - (8.5 / 2)
    End With

Hope this helps!

 

[ifu06416]

After your code creates the diamond shapes and connector, you can add the following lines to your code. Change the width and height as desired.

    ws.Shapes.AddTextbox msoTextOrientationHorizontal, Start_Diamond.Left, Start_Diamond.Top + 15, 75, 20
  
    ws.Shapes.AddTextbox msoTextOrientationHorizontal, End_Diamond.Left, End_Diamond.Top + 15, 75, 20

By the way, when I provided you with the code in a previous thread, I didn't know that each month contained 5 columns. So if you want the ending diamond positioned in the 5th column instead of the 1st, use the following code instead . . .

    'find end position
    With End_Range.Offset(, 4)
        End_Pos = .Left + (.Width / 2) - (8.5 / 2)
    End With

Hope this helps!

Hi there,

Thanks for this, it works perfectly.

Bit annoyed I couldn't get it myself though. I had this same code but with brackets around the textbox parameters

Thanks again,

John.

 

[Domenic]

Don't be hard on yourself. It's a learning process. I'm always learning something new.

Anyway, I'm glad I could help. And thanks for the feedback.

Cheers!