Thema Datum  Von Nutzer Rating
Antwort
Rot AutoSize bei SmartArt
 30.09.2021 09:22:35 Mathias
NotSolved

Ansicht des Beitrags:
Von:
Mathias		 Datum:
30.09.2021 09:22:35		 Views:
1051		 Rating:
     
Antwort:
  Ja
Thema:
AutoSize bei SmartArt

Hallo Zusammen,

ich versuche in Excel mit VBA ein Organigramm über eine Liste zu erstellen. Dazu nutze ich SmartArts. Das erstellen des Organigramm funktioniert soweit sehr gut. Nur habe ich das Problem, dass ich noch keine Lösung für folgendes Thema habe:

- die Schriftgröße gebe ich mit 8 vor.

- der Text soll keinen automatischen Umbruch haben

- die Größe des Kastens soll an die Textgröße angepasst werden für jede Person im Chart.

Bei dem Zugriff auf AutoSize bekomme ich immer einen Laufzeit Fehler: Laufzeitfehler '-2147024809 (80070057)' Der angegebene Wert ist außerhalb des zulässigen Bereichs.

With QNode.Shapes(1).TextFrame2
        .TextRange.Font.Fill.ForeColor.RGB = vbBlack
        .WordWrap = msoFalse
        .AutoSize = msoAutoSizeShapeToFitText -> Fehler!!!

Vielen Dank schon mal für die Unterstützung!!!

Gruß

Mathias

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
Dim sTabHCPlanning As String
Dim sTabOrgChart As String
 
Private Sub BtnUpdateOrgChart_Click()
    createOrgChart
End Sub
 
 
Sub createOrgChart()
 
    Dim shp As Shape
    Dim ogSALayout As SmartArtLayout
    Dim ogShp As Shape
    Dim QNodes As SmartArtNodes
    Dim QNode As SmartArtNode
    Dim t As Long
    Dim i As Long
    Dim Code As String
     
    sTabOrgChart = "Organization Chart"
    sTabHCPlanning = "HC Planning"
     
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False
 
    For Each shp In Worksheets(sTabOrgChart).Shapes
        If shp.Type = msoSmartArt Then
            shp.Delete
        End If
    Next shp
 
    Set ogSALayout = Application.SmartArtLayouts("urn:microsoft.com/office/officeart/2005/8/layout/orgChart1")
    Set ogShp = Worksheets(sTabOrgChart).Shapes.AddSmartArt(ogSALayout, 50, 50) ', 1200, 1200)
    Set QNodes = ogShp.SmartArt.AllNodes
    t = QNodes.Count
 
    ' Delete all nodes except one
    For i = 2 To t
        ogShp.SmartArt.Nodes(1).Delete
    Next i
 
    ' Set root node properties
    Set QNode = QNodes(1)
    With QNode.Shapes(1).TextFrame2
        .TextRange.Font.Fill.ForeColor.RGB = vbBlack
        .WordWrap = msoFalse
        .AutoSize = msoAutoSizeShapeToFitText
        .MarginBottom = 10
        .MarginLeft = 10
        .MarginRight = 10
        .MarginTop = 10
        .TextRange.Font.Size = 8
        .TextRange.Text = Worksheets(sTabHCPlanning).Range("D4").Value & Chr(10) & Worksheets(sTabHCPlanning).Range("C4").Value
    End With
     
    QNode.Shapes(1).Fill.ForeColor.RGB = RGB(221, 221, 221)
     
    Code = Worksheets(sTabHCPlanning).Range("A4").Value
 
    ' Recursively add children nodes
    Call AddChildren(QNode, Code)
              
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
 
End Sub
 
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 1000 'Worksheets(sTabHCPlanning).Range("A2").End(xlDown).Row
        ' Look for correct level and code
        If Worksheets(sTabHCPlanning).Range("E" & r).Value = Level And Worksheets(sTabHCPlanning).Range("A" & r).Value Like Code & ".*" Then
            ' Create new node
            Set QChild = QParent.AddNode(msoSmartArtNodeBelow)
            ' Set node properties
            With QChild.Shapes(1).TextFrame2
                .TextRange.Text = Worksheets(sTabHCPlanning).Range("D" & r).Value & Chr(10) & Worksheets(sTabHCPlanning).Range("C" & r).Value
                .TextRange.Font.Fill.ForeColor.RGB = vbBlack
                .WordWrap = msoFalse
                .MarginBottom = 10
                .MarginLeft = 10
                .MarginRight = 10
                .MarginTop = 10
                .TextRange.Font.Size = 8
            End With
            If StrConv(Trim(Worksheets(sTabHCPlanning).Range("F" & r).Value), vbUpperCase) = "RETIRED" Then
                QChild.Shapes(1).Fill.ForeColor.RGB = RGB(255, 80, 80)
                QChild.Shapes(1).TextFrame2.TextRange.Text = Worksheets(sTabHCPlanning).Range("D" & r).Value & " - RETIRED" & Chr(10) & Worksheets(sTabHCPlanning).Range("C" & r).Value
            Else
                If StrConv(Trim(Worksheets(sTabHCPlanning).Range("F" & r).Value), vbUpperCase) = "NEW" Then
                    QChild.Shapes(1).Fill.ForeColor.RGB = RGB(51, 204, 51)
                    QChild.Shapes(1).TextFrame2.TextRange.Text = Worksheets(sTabHCPlanning).Range("D" & r).Value & " - NEW" & Chr(10) & Worksheets(sTabHCPlanning).Range("C" & r).Value
                Else
                    If StrConv(Trim(Worksheets(sTabHCPlanning).Range("F" & r).Value), vbUpperCase) = "SUBSTITUDE" Then
                        QChild.Shapes(1).Fill.ForeColor.RGB = RGB(51, 204, 51)
                        QChild.Shapes(1).TextFrame2.TextRange.Text = Worksheets(sTabHCPlanning).Range("D" & r).Value & " - SUBSTITUDE" & Chr(10) & Worksheets(sTabHCPlanning).Range("C" & r).Value
                    Else
                        If StrConv(Trim(Worksheets(sTabHCPlanning).Range("G" & r).Value), vbUpperCase) = "DEPARTMENT" Then
                            QChild.Shapes(1).Line.ForeColor.RGB = RGB(255, 51, 0)
                            QChild.Shapes(1).Fill.ForeColor.RGB = RGB(228, 228, 228)
                            QChild.Shapes(1).TextFrame2.TextRange.Font.Bold = msoCTrue
                            QChild.Shapes(1).TextFrame2.TextRange.Text = Worksheets(sTabHCPlanning).Range("D" & r).Value & " [" & Worksheets(sTabHCPlanning).Range("D" & (r - 1)).Value & "]" & Chr(10) & Worksheets(sTabHCPlanning).Range("C" & r).Value
                        Else
                            If StrConv(Trim(Worksheets(sTabHCPlanning).Range("G" & r).Value), vbUpperCase) = "TEAM" Then
                                QChild.Shapes(1).Line.ForeColor.RGB = RGB(51, 204, 51)
                                QChild.Shapes(1).Fill.ForeColor.RGB = RGB(228, 228, 228)
                                QChild.Shapes(1).TextFrame2.TextRange.Font.Bold = msoCTrue
                                QChild.Shapes(1).TextFrame2.TextRange.Text = Worksheets(sTabHCPlanning).Range("D" & r).Value & " [" & Worksheets(sTabHCPlanning).Range("D" & (r - 1)).Value & "]" & Chr(10) & Worksheets(sTabHCPlanning).Range("C" & r).Value
                            Else
                                If StrConv(Trim(Worksheets(sTabHCPlanning).Range("F" & r).Value), vbUpperCase) = "OPEN" Then
                                    QChild.Shapes(1).Fill.ForeColor.RGB = RGB(255, 153, 0)
                                    QChild.Shapes(1).TextFrame2.TextRange.Text = Worksheets(sTabHCPlanning).Range("D" & r).Value & " - OPEN" & Chr(10) & Worksheets(sTabHCPlanning).Range("C" & r).Value
                                Else
                                    If StrConv(Trim(Worksheets(sTabHCPlanning).Range("F" & r).Value), vbUpperCase) = "RESIGNED" Then
                                        QChild.Shapes(1).Fill.ForeColor.RGB = RGB(255, 80, 80)
                                        QChild.Shapes(1).TextFrame2.TextRange.Text = Worksheets(sTabHCPlanning).Range("D" & r).Value & " - RESIGNED" & Chr(10) & Worksheets(sTabHCPlanning).Range("C" & r).Value
                                    Else
                                        QChild.Shapes(1).Fill.ForeColor.RGB = RGB(228, 228, 228)
                                    End If
                                End If
                            End If
                        End If
                    End If
                End If
            End If
             
            ' Recursion!
            Call AddChildren(QChild, Worksheets(sTabHCPlanning).Range("A" & r).Value)
        End If
    Next r
End Sub

 

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:
WYSIWYG-Editor, ctl00_Content_editor1



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot AutoSize bei SmartArt
 30.09.2021 09:22:35 Mathias
NotSolved