Add a textbox below node in diagrams VBA Excel - excel

Question

Hi i am making a organisational hierarchy chart and i want to have a textbox below each nodes. What i did until now was to retrieve the data and plot out the hierarchy. But how do i add textbox under them? I have to add 2 textboxes below each nodes. Any help will be appreciated!
Code:
Option Explicit
Sub OrgChart()
Dim ogSALayout As SmartArtLayout
Dim QNodes As SmartArtNodes
Dim QNode As SmartArtNode
Dim ogShp As Shape
Dim shp As Shape
Dim t As Long
Dim i As Long
Dim r As Long
For Each shp In ActiveSheet.Shapes
If shp.Type = msoSmartArt Then: shp.Delete
Next shp
Set ogSALayout = Application.SmartArtLayouts( _
"urn:microsoft.com/office/officeart/2009/3/layout/HorizontalOrganizationChart" _
)
Set ogShp = ActiveSheet.Shapes.AddSmartArt(ogSALayout, 630, 36, 1000, 1000)
Set QNodes = ogShp.SmartArt.AllNodes
t = QNodes.Count
For i = 2 To t: ogShp.SmartArt.Nodes(1).Delete: Next i
Set QNode = QNodes(1)
If Range("D1").Value = "CONFIRM" Then
QNode.Shapes.Fill.ForeColor.RGB = RGB(255, 0, 0)
ElseIf Range("D1").Value = "PENDING" Then
QNode.Shapes.Fill.ForeColor.RGB = RGB(128, 128, 128)
ElseIf Range("D1").Value = "SUSPECTED" Then
QNode.Shapes.Fill.ForeColor.RGB = RGB(255, 255, 0)
ElseIf Range("D1").Value = "NO" Then
QNode.Shapes.Fill.ForeColor.RGB = RGB(0, 255, 0)
End If
With QNode.TextFrame2.TextRange
.Text = Range("B1").Value
.Font.Fill.ForeColor.RGB = vbBlack
.Font.Size = 12
.Font.Bold = True
End With
With QNode.Shapes.AddTextbox(msoTextOrientationHorizontal, _
100, 100, 200, 50) _
.TextFrame.Characters.Text = "Test Box"
End With
r = 1
Call AddChildren(QNode, r)
ogShp.Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
End Sub
Sub AddChildren(ByVal QParent As SmartArtNode, ByVal r As Long)
Dim QChild As SmartArtNode
Dim Level As Long
Dim s As Long
Const MyCol As String = "C"
Level = Range(MyCol & r).Value
s = r + 1
Do While Range(MyCol & s).Value > Level
If Range(MyCol & s).Value = Level + 1 Then
Set QChild = QParent.AddNode(msoSmartArtNodeBelow)
If Range("D" & s).Value = "CONFIRM" Then
QChild.Shapes.Fill.ForeColor.RGB = RGB(255, 0, 0)
ElseIf Range("D" & s).Value = "PENDING" Then
QChild.Shapes.Fill.ForeColor.RGB = RGB(128, 128, 128)
ElseIf Range("D" & s).Value = "SUSPECTED" Then
QChild.Shapes.Fill.ForeColor.RGB = RGB(255, 255, 0)
ElseIf Range("D" & s).Value = "NO" Then
QChild.Shapes.Fill.ForeColor.RGB = RGB(0, 255, 0)
End If
With QChild.TextFrame2.TextRange
.Text = Range("B" & s).Value
.Font.Fill.ForeColor.RGB = vbBlack
.Font.Size = 12
End With
Call AddChildren(QChild, s)
End If
s = s + 1
Loop
End Sub
This is what it looks like now:
Edit: Added screenshot of data layout.

Answer 1

Adding a textbox under a node would mean that you would have to move the node up to make room for the textbox. As far as I know, it's not possible to move the nodes using VBA.
As a workaround, you could create another node under each node and format it as a textbox.
The outcome would look something like this:
To do this, I would first remove this from OrgChart
With QNode.Shapes.AddTextbox(msoTextOrientationHorizontal, _
100, 100, 200, 50) _
.TextFrame.Characters.Text = "Test Box"
End With
And replace it with:
Dim PseudoTxtBox As SmartArtNode
Set PseudoTxtBox = QNode.AddNode(msoSmartArtNodeAfter) 'Pseudo text box
'Add some text to the textbox
With PseudoTxtBox.TextFrame2.TextRange
.Text = "Some Text"
.Font.Fill.ForeColor.RGB = vbBlack
.Font.Size = 12
End With
'Make the textbox background transparent
PseudoTxtBox.Shapes.Fill.Transparency = 1
Then I would insert the following code right after adding the node in AddChildren :
Dim PseudoTxtBox As SmartArtNode
Set PseudoTxtBox = QChild.AddNode(msoSmartArtNodeAfter) 'Pseudo text box
'Add some text to the textbox
With PseudoTxtBox.TextFrame2.TextRange
.Text = "Some Text"
.Font.Fill.ForeColor.RGB = vbBlack
.Font.Size = 12
End With
'Make the textbox background transparent
PseudoTxtBox.Shapes.Fill.Transparency = 1
'Get the parent shape
Dim mshp As Shape
Dim tempObject As Object
Set tempObject = QChild.Parent
Do While TypeName(tempObject) <> "Shape"
Set tempObject = tempObject.Parent
Loop
Set mshp = tempObject
'Set the corresponding connector (line) to be transparent.
mshp.GroupItems(Level).Line.Transparency = 1