ORG Chart Problem mit Assistent Anzeige
09.06.2020 20:17:42
Stefan
ich habe ein ganz nettes Tool entwickelt, wo man Organigramme , Projektstrukturpläne, Stammbäume u.ä. ganz nach belieben aufbauen und dann farblich angepasst darstellen und auch exportieren kann. Wenn ich die neue Assistentendarstellung verwende , hab ich das Problem, dass nicht alle Smart Art Chart Arten diese Darstellung beherrschen und in diesen Fällen das Makro einfach (logisch , dass das passiert) abstürzt.
Mein Kopf schwirrt gerade, aber vielleicht hat ja einer von Euch die rascheste Idee, wie ich das Abstürzen verhindere, dass für diese Chart Art einfach die Default Darstellung (ohne Assistent) genommen wird.?
Anbei das Codesnippet und auch meine Beispieldatei,
in fett die problematischen Codezeilen meinerseits. 5 Charttypen sind auswählbar, für Horizontal2 und Table Hierarchy geht die Assistentendarstellung nicht.
Sub AddChildren(ByVal QParent As SmartArtNode, ByVal Code As String)
Dim Level As Long
Dim v As Variant
Dim r As Long
Dim QChild As SmartArtNode
' Dissect the code
v = Split(Code, ".")
' Next level
Level = UBound(v) + 2
' Loop through the rows
For r = 2 To Range("A1").End(xlDown).Row
' Look for correct level and code
If Range("C" & r).Value = Level And Range("H" & r).Value Like Code & ".*" Then
' 08.06.2020 Create new node - hier muss man für Assistant anpassen
If Range("O" & r).Value = "" Then
Set QChild = QParent.AddNode(msoSmartArtNodeBelow, msoSmartArtNodeTypeDefault)
Else
Set QChild = QParent.AddNode(msoSmartArtNodeDefault, msoSmartArtNodeTypeAssistant)
End If
'alt Set QChild = QParent.AddNode(msoSmartArtNodeBelow)
' Set node properties
With QChild.TextFrame2.TextRange
.Text = Range("B" & r).Value
.Font.Fill.ForeColor.RGB = Range("C" & r).Font.Color
.Font.Size = 5
.Font.Italic = Range("C" & r).Font.Italic
If Range("C" & r).Font.Underline = xlUnderlineStyleSingle Then
.Font.UnderlineColor = Range("C" & r).Font.Color 'hier wird die _
Schriftfarbe übernommen - color of font
.Font.UnderlineStyle = msoUnderlineSingleLine 'hier kommt unterstrichen? - _
underlined?
End If
.Font.Strikethrough = Range("C" & r).Font.Strikethrough 'hier kommt _
durchgestrichen? - strikethrough?
'.Font.FontStyle = Range("C" & r).Font.FontStyle
.Font.Bold = Range("C" & r).Font.Bold
End With
QChild.Shapes(1).Fill.ForeColor.RGB = Range("C" & r).Interior.Color
On Error Resume Next
QChild.Shapes(1).Line.DashStyle = Range("D" & r).Value
QChild.Shapes(1).Line.Weight = Range("E" & r).Value
QChild.Shapes(1).Line.ForeColor.RGB = Range("F" & r).Interior.Color
On Error GoTo 0
If strType = "Pic ORG" Then
'Stefan Sandauer - 8.6.2016
If Range("G" & r).Value = "" Then
QChild.Shapes(2).Fill.UserPicture ThisWorkbook.Path & "\img0.wmf"
Else
QChild.Shapes(2).Fill.UserPicture ThisWorkbook.Path & "\img" & Range("G" & _
r).Value & ".wmf"
End If
End If
' Recursion!
Call AddChildren(QChild, Range("H" & r).Value)
End If
Next r
End Sub