VBA add textbox to shapes

Doflamingo

Board Regular
Joined
Apr 16, 2019
Messages
238
Dear all, I'm trying to find a way to add textbox to shape created by the code below

Code:
Sub créeShape(parent, niv, Attribut, coul) 
  hauteurshape = 48
  largeurshape = 92
  colonne = colonne + 1
  forga.Shapes.AddShape(msoShapeRectangle, 10, 10, largeurshape, hauteurshape).Name = parent
  forga.Shapes(parent).Line.ForeColor.SchemeColor = 0
  txt = parent & vbLf & Attribut
  With forga.Shapes(parent)
    .AddTextbox(msoTextOrientationHorizontal, 100, 100, 200, 50).TextFrame.Characters.Text = "txt"
    .TextFrame.Characters.Text = txt
    .TextFrame.Characters(Start:=1, Length:=1000).Font.Size = 10
    .TextFrame.Characters(Start:=1, Length:=1000).Font.ColorIndex = 0
    .TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.Bold = True
    .TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.ColorIndex = 1
    .Fill.ForeColor.RGB = coul


  End With
  forga.Shapes(parent).Left = débutOrg.Left + inth * colonne
  forga.Shapes(parent).Top = débutOrg.Top + intv * (niv - 1)
  For i = 1 To n
    If Tbl(i, 1) = parent And niv > 1 Then
      shapePère = Tbl(i, 2)
      forga.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100).Name = parent & "c"
      forga.Shapes(parent & "c").Line.ForeColor.SchemeColor = 0
      forga.Shapes(parent & "c").ConnectorFormat.BeginConnect forga.Shapes(shapePère), 3
      forga.Shapes(parent & "c").ConnectorFormat.EndConnect forga.Shapes(parent), 1
   End If
   If Tbl(i, 2) = parent Then créeShape Tbl(i, 1), niv + 1, Tbl(i, 3), f.Cells(i + 1, 1).Interior.Color
  Next i
End Sub
But here the line in red I have added and it does not work, any ideas ?


Code:
Sub créeShape(parent, niv, Attribut, coul) 
  hauteurshape = 48
  largeurshape = 92
  colonne = colonne + 1
  forga.Shapes.AddShape(msoShapeRectangle, 10, 10, largeurshape, hauteurshape).Name = parent
  forga.Shapes(parent).Line.ForeColor.SchemeColor = 0
 [COLOR=#ff0000] txt = parent & vbLf & Attribut[/COLOR]


  With forga.Shapes(parent)
[COLOR=#ff0000]    .AddTextbox(msoTextOrientationHorizontal, 100, 100, 200, 50).TextFrame.Characters.Text = "txt"[/COLOR]
    .TextFrame.Characters.Text = txt
    .TextFrame.Characters(Start:=1, Length:=1000).Font.Size = 10
    .TextFrame.Characters(Start:=1, Length:=1000).Font.ColorIndex = 0
    .TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.Bold = True
    .TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.ColorIndex = 1
    .Fill.ForeColor.RGB = coul


  End With
  forga.Shapes(parent).Left = débutOrg.Left + inth * colonne
  forga.Shapes(parent).Top = débutOrg.Top + intv * (niv - 1)
  For i = 1 To n
    If Tbl(i, 1) = parent And niv > 1 Then
      shapePère = Tbl(i, 2)
      forga.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100).Name = parent & "c"
      forga.Shapes(parent & "c").Line.ForeColor.SchemeColor = 0
      forga.Shapes(parent & "c").ConnectorFormat.BeginConnect forga.Shapes(shapePère), 3
      forga.Shapes(parent & "c").ConnectorFormat.EndConnect forga.Shapes(parent), 1
   End If
   If Tbl(i, 2) = parent Then créeShape Tbl(i, 1), niv + 1, Tbl(i, 3), f.Cells(i + 1, 1).Interior.Color
  Next i
End Sub
 

Some videos you may like

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
10,192
Office Version
2007
Platform
Windows
Try this

Code:
Sub créeShape(parent, niv, Attribut, coul)
    hauteurshape = 48
    largeurshape = 92
    colonne = colonne + 1
    With forga.Shapes
        .AddShape(msoShapeRectangle, 10, 10, largeurshape, hauteurshape).Name = parent
        forga.Shapes(parent).Line.ForeColor.SchemeColor = 0
        txt = parent & vbLf & Attribut
[COLOR=#ff0000]        boxName = "txt" & parent[/COLOR]
        .AddTextbox(msoTextOrientationHorizontal, 12, 12, largeurshape - 4, hauteurshape - 4).Name = [COLOR=#ff0000]boxName[/COLOR]
        With forga.Shapes([COLOR=#ff0000]boxName[/COLOR])
            .TextFrame.Characters.Text = txt
            .TextFrame.Characters(Start:=1, Length:=1000).Font.Size = 10
            .TextFrame.Characters(Start:=1, Length:=1000).Font.ColorIndex = 0
            .TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.Bold = True
            .TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.ColorIndex = 1
            .Fill.ForeColor.RGB = coul
        End With
    End With
    
[COLOR=#0000ff]    'Move form and textbox[/COLOR]
    forga.Shapes(parent).Left = débutOrg.Left + inth * colonne
    forga.Shapes(parent).Top = débutOrg.Top + intv * (niv - 1)
    
    forga.Shapes([COLOR=#ff0000]boxName[/COLOR]).Left = débutOrg.Left + inth * colonne [COLOR=#ff0000]+ 2[/COLOR]
    forga.Shapes([COLOR=#ff0000]boxName[/COLOR]).Top = débutOrg.Top + intv * (niv - 1) [COLOR=#ff0000]+ 2[/COLOR]
    
End Sub
 

Forum statistics

Threads
1,089,299
Messages
5,407,452
Members
403,143
Latest member
CTremblay

This Week's Hot Topics

  • help please
    SORRY NOT ANY GOOD AT EXCEL SO HELP WOULD BE MUCH APPRECIATED this formula is in a sheet called ignore...
  • two formulas needed
    Hello, I'll try my best to explain this: First formula needed in Sheet1 cell A2: If Sheet1 cell B2 = Sheet2 cell B2 then return a 1. If not then...
  • Dynamic Counts
    Good afternoon, we are tidying up some data & the data seems to be growing quicker than we are tidying it up! What we confirm (by reviewing it...
  • Help Excel formula eliminate duplicate values and keep only 2 identical rows.
    as picture below column A has a duplicate value. but the values are not the same as the rule. sometimes 4 rows, sometimes 10 rows or 7 or 9...
  • Macro Compile Error Sub or Function not defined
    Hello, I am trying to run macros from a validation list, all macros have been created and run perfectly on there own but I'm getting a compile...
  • Last row combined with Current Region VBA
    I'm generally happy finding the last row of data through something like Lastrow = Cells(Rows.Count, "D").End(xlUp) but I don't always receive data...
Top