Добавить текстовое поле ниже узла в диаграммах VBA Excel

Question

Привет! Я делаю диаграмму организационной иерархии и хочу, чтобы текстовое поле располагалось под каждым узлом До сих пор я занимался извлечением данных и построением иерархии. Но как мне добавить текстовое поле под ними? Я должен добавить 2 текстовых поля ниже каждого узла. Любая помощь будет оценена! Код:

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

Вот как это выглядит сейчас:

Редактировать: Добавлен скриншот макета данных.

Answer 1

Добавление текстового поля под узлом будет означать, что вам придется переместить узел вверх, чтобы освободить место для текстового поля. Насколько я знаю, невозможно перемещать узлы с помощью VBA.

В качестве обходного пути можно создать еще один узел под каждым узлом и отформатировать его как текстовое поле. Результат будет выглядеть примерно так:

Чтобы сделать это, я сначала удалил это из OrgChart

With QNode.Shapes.AddTextbox(msoTextOrientationHorizontal, _
100, 100, 200, 50) _
.TextFrame.Characters.Text = "Test Box"
End 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

Тогда я бы вставил следующий код сразу после добавления узла в 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