Layout troubles with VBA-generated OrgChart in Excel

[Daniel Hohenberger]

Hi,

I create a OrgChart via VBA in Excel (more exactly, I run a VBA sub in Excel,
which starts up Word, creates the chart there, then copies it to Excel, because
in Excel you can't put text in the chart's shapes). The problem is, that the
layout looks seriously broken. Shapes are sized wrong and moved away from the
lines connecting them. This can be fixed by manually (doesn't seem to work via
VBA) selecting the chart and then an empty cell repeatedly. This seams to
trigger the layout somehow.
Does anyone know what I might do wrong or how to fix this behaviour?

Greets,
Daniel

P.S.: The following code will demonstrate the problem

Sub CreateOrgChart()

'Excel objects
Dim ws As Worksheet
Set ws = Worksheets(1)

'Word objects
Dim wOrgChart As Word.Shape
Dim wChartRoot As Word.DiagramNode
Dim wCurrentNode As Word.DiagramNode
Dim wShapes As Word.shapes
Dim wApp As Word.Application
Set wApp = New Word.Application

wApp.Visible = True
wApp.Activate

'Open a new Word document
wApp.Documents.Add
Set wShapes = wApp.ActiveDocument.shapes

'Add a shape
Set wOrgChart = wShapes.AddDiagram(msoDiagramOrgChart, 8, 16, 300, 300)
Set wChartRoot = wOrgChart.DiagramNode.Children.AddNode(msoDiagramNode)
With wChartRoot
.Diagram.AutoLayout = msoTrue
.Diagram.AutoFormat = msoFalse
.Layout = msoOrgChartLayoutStandard
With .TextShape.TextFrame
.AutoSize = msoTrue
.TextRange.FitTextWidth = msoTrue
.TextRange.Font.Color = wdColorWhite
.TextRange.text = "root" & Chr(10) & "Name"
.TextRange.Words(1).Italic = True
End With
End With

Dim i As Byte
Dim j As Byte
For i = 1 To 3
Call AddChild(wChartRoot, msoDiagramNode)
Set wCurrentNode = wChartRoot.Children(i)
For j = 1 To i
Call AddChild(wCurrentNode, msoDiagramNode)
Next j
Next i

'Copy finished Chart to Excel
wShapes.SelectAll
wApp.Selection.Copy
ws.Paste

Dim eShape As Shape
For Each eShape In ws.shapes
If eShape.HasDiagram = msoTrue Then
With eShape
.Height = 600
.Width = 800
End With
End If
Next eShape

'Quit Word
wApp.Quit saveChanges:=False

End Sub

Sub AddChild(parent As Word.DiagramNode, nodeType As MsoDiagramNodeType)

Dim wCurrentNode As Word.DiagramNode
Dim wAssistant As Word.DiagramNode
Set wCurrentNode = parent.Children.AddNode(-1, nodeType)

With wCurrentNode
.Layout = msoOrgChartLayoutStandard
With .TextShape.TextFrame
.MarginLeft = 5
.MarginRight = 5
.AutoSize = msoTrue
With .TextRange
.text = "testelement: something"
.Words(1).Italic = True
.FitTextWidth = msoTrue
End With
End With
End With
If nodeType = msoDiagramNode Then
Dim i As Byte
For i = 1 To 3
Call AddChild(wCurrentNode, msoDiagramAssistant)
Next i
End If
End Sub

 

[Daniel Hohenberger]

nobody?