CODEWITHSUNDEEP
excelvba
Ruiru
Ruiru

Reputation: 117

Add a textbox below node in diagrams VBA Excel

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: diagram

Edit: Added screenshot of data layout. data

Upvotes: 1

Views: 370

Answers (1)

DecimalTurn
DecimalTurn

Reputation: 4278

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: enter image description here

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

Upvotes: 1

Related Questions