SmartArt per VBA Referenzieren
Andre
Wie das Betreff schon sagt such ich einen Zugang zu den, wie ich
finde, ganz guten SmartArt-Objekten und zwar über VBA. Ich vermute,
das Objekt ist ein Shape, aber ich finde kein Objekt und keine
Referenz aus das, was das "SmartArt-Objekt" sein müssten.
Hntergrund: Ich will beispielsweise ein mittels SmartArt angelegtes
Organigramm auslesen.
Gruß, André.
Melanie Breden
"Andre" schrieb:
> Wie das Betreff schon sagt such ich einen Zugang zu den, wie ich
> finde, ganz guten SmartArt-Objekten und zwar �ber VBA. Ich vermute,
> das Objekt ist ein Shape, aber ich finde kein Objekt und keine
> Referenz aus das, was das "SmartArt-Objekt" sein m�ssten.
> Hntergrund: Ich will beispielsweise ein mittels SmartArt angelegtes
> Organigramm auslesen.
SmartArts sind leider nicht im Objektmodell integriert und k�nnen deshalb auch
nicht mit VBA erstellt und bearbeitet werden.
Genau wie die Multifunktionsleiste lassen sich SmartArts ausschlie�lich per XML-Code
generieren. Hier kenne ich die Vorgehensweise allerdings auch nicht.
Die xml Dateien kannst du dir anschauen, indem du den Dateinamen der geschlossenen Datei
um die Endung ".zip" erweiterst im Ordner 'xl/diagrams' die xml-Dateien mit einem Editor �ffnest.
Mit freundlichen Gr�ssen
Melanie Breden
--
- Microsoft MVP f�r Excel -
www.melanie-breden.de
Ribbon-Programmierung f�r Office 2007 http://tinyurl.com/59awla
Andre
> Hallo André,
>
> "Andre" schrieb:
>
> > Wie das Betreff schon sagt such ich einen Zugang zu den, wie ich
> > das Objekt ist ein Shape, aber ich finde kein Objekt und keine
> > Hntergrund: Ich will beispielsweise ein mittels SmartArt angelegtes
> > Organigramm auslesen.
>
> nicht mit VBA erstellt und bearbeitet werden.
>
> generieren. Hier kenne ich die Vorgehensweise allerdings auch nicht.
>
> Die xml Dateien kannst du dir anschauen, indem du den Dateinamen der geschlossenen Datei
>
> Mit freundlichen Grüssen
> Melanie Breden
>
> --
> - Microsoft MVP für Excel -www.melanie-breden.de
>
> Ribbon-Programmierung für Office 2007http://tinyurl.com/59awla
Das hatte ich befürchtet. Ich merke schon, ich werde zu alt.
Trotzdem danke!
Michael Schwimmer
Am Mon, 4 May 2009 01:36:24 -0700 (PDT) schrieb Andre:
> Wie das Betreff schon sagt such ich einen Zugang zu den, wie ich
> finde, ganz guten SmartArt-Objekten und zwar �ber VBA. Ich vermute,
> das Objekt ist ein Shape, aber ich finde kein Objekt und keine
> Referenz aus das, was das "SmartArt-Objekt" sein m�ssten.
> Hntergrund: Ich will beispielsweise ein mittels SmartArt angelegtes
> Organigramm auslesen.
auslesen kannst du das mit VBA schon, das Setzen der Eigenschaften wird
aber unterbunden. Ich habe es jedenfalls nicht geschafft, den Text oder
andere Eigenschaften unter Excel 2007 (In diesem Fall einfache Blockliste)
zu �ndern. Es konnt immer der Fehler 70, Zugriff verweigert:
Sub Test()
Dim objShape As Shape
Dim varTemp As Variant
Dim objSmartArt As Object
Set objSmartArt = ActiveSheet.Shapes(1)
For Each objShape In objSmartArt.GroupItems
varTemp = objShape.TextFrame2.TextRange.Text
varTemp = objShape.TextFrame2.TextRange.Characters
' Fehler 70 Zugriff verweigert
' objShape.TextFrame2.TextRange.Text = "a"
varTemp = objShape.TextFrame2.TextRange.Count
varTemp = objShape.TextFrame2.TextRange.BoundHeight
varTemp = objShape.TextFrame2.TextRange.BoundWidth
varTemp = objShape.TextFrame2.TextRange.BoundLeft
varTemp = objShape.TextFrame2.TextRange.BoundTop
' Fontobject referenzieren
Set varTemp = objShape.TextFrame2.TextRange.Font
' Eine Fonteigenschaft
varTemp = objShape.TextFrame2.TextRange.Font.Bold
' Fehler 70 Zugriff verweigert
' objShape.TextFrame2.TextRange.Font.Bold = True
Next
End Sub
Viele Gr��e
Michael
--
http://michael-schwimmer.de
Masterclass Excel VBA ISBN-10: 3827325250
Das Excel-VBA Codebook ISBN-10: 3827324718
Microsoft Office Excel 2007-Programmierung ISBN-10: 3866454139
Andre
wrote:
> Hallo Andre,
>
> Am Mon, 4 May 2009 01:36:24 -0700 (PDT) schrieb Andre:
>
> > Wie das Betreff schon sagt such ich einen Zugang zu den, wie ich
> > das Objekt ist ein Shape, aber ich finde kein Objekt und keine
> > Hntergrund: Ich will beispielsweise ein mittels SmartArt angelegtes
> > Organigramm auslesen.
>
> auslesen kannst du das mit VBA schon, das Setzen der Eigenschaften wird
> aber unterbunden. Ich habe es jedenfalls nicht geschafft, den Text oder
> andere Eigenschaften unter Excel 2007 (In diesem Fall einfache Blockliste)
>
> Sub Test()
> Dim objShape As Shape
> Dim varTemp As Variant
> Dim objSmartArt As Object
>
> Set objSmartArt = ActiveSheet.Shapes(1)
>
> For Each objShape In objSmartArt.GroupItems
> varTemp = objShape.TextFrame2.TextRange.Text
> varTemp = objShape.TextFrame2.TextRange.Characters
> ' Fehler 70 Zugriff verweigert
> ' objShape.TextFrame2.TextRange.Text = "a"
> varTemp = objShape.TextFrame2.TextRange.Count
> varTemp = objShape.TextFrame2.TextRange.BoundHeight
> varTemp = objShape.TextFrame2.TextRange.BoundWidth
> varTemp = objShape.TextFrame2.TextRange.BoundLeft
> varTemp = objShape.TextFrame2.TextRange.BoundTop
> ' Fontobject referenzieren
> Set varTemp = objShape.TextFrame2.TextRange.Font
> ' Eine Fonteigenschaft
> varTemp = objShape.TextFrame2.TextRange.Font.Bold
> ' Fehler 70 Zugriff verweigert
> ' objShape.TextFrame2.TextRange.Font.Bold = True
> Next
> End Sub
>
> Michael
>
> --http://michael-schwimmer.de
> Masterclass Excel VBA ISBN-10: 3827325250
> Das Excel-VBA Codebook ISBN-10: 3827324718
> Microsoft Office Excel 2007-Programmierung ISBN-10: 3866454139
Toll, das reicht mir schon.
Danke!
Andre
>
> - Zitierten Text anzeigen -
Oh - reicht mir doch nicht: Ich habe so meine Schwierigkeiten mit den
Shapes: Kriege ich die Beziehung zwischen den einzelnen Textblöcken
denn auch raus?
Michael Schwimmer
Am Mon, 11 May 2009 02:37:25 -0700 (PDT) schrieb Andre:
>>> > Wie das Betreff schon sagt such ich einen Zugang zu den, wie ich
>>> > finde, ganz guten SmartArt-Objekten und zwar �ber VBA. Ich vermute,
>>> > das Objekt ist ein Shape, aber ich finde kein Objekt und keine
>>> > Referenz aus das, was das "SmartArt-Objekt" sein m�ssten.
>>> > Hntergrund: Ich will beispielsweise ein mittels SmartArt angelegtes
>>> > Organigramm auslesen.
>>
>>> auslesen kannst du das mit VBA schon, das Setzen der Eigenschaften wird
>>> aber unterbunden. Ich habe es jedenfalls nicht geschafft, den Text oder
> Oh - reicht mir doch nicht: Ich habe so meine Schwierigkeiten mit den
> Shapes: Kriege ich die Beziehung zwischen den einzelnen Textbl�cken
> denn auch raus?
das Problem ist, dass es darin keine Hierachie gibt.
Alle Shapes, auch die, welche die Verbindungslinien darstellen, sind
gleichberechtigt. �ber die Verbindungslinien k�nnte man aber versuchen, die
Abh�ngigkeiten nachzuvollziehen.
Bei einem Organigramm funktioniert nach ersten Tests folgendes:
Sub testen()
Dim objShape As Shape
Dim colResult As Collection
Set objShape = ActiveSheet.shapes(1)
Set colResult = FindChild(objShape)
End Sub
Private Function FindChild(objShape As Shape) As Collection
Dim colResult As New Collection
Dim colShapes As New Collection
Dim colLines As New Collection
Dim colTemp As Collection
Dim colChildLine As Collection
Dim varLine As Variant
Dim varTemp As Variant
Dim varShape As Variant
Dim astrText() As String
Dim i As Long
Dim k As Long
On Error Resume Next
' Linien und Formen in jeweils einer eigenen
' Collection speichern
For Each varTemp In objShape.GroupItems
' Tempor�re Collection anlegen
Set colTemp = New Collection
If varTemp.Type <> msoLine Then
k = k + 1
colTemp.Add varTemp
colTemp.Add "Shape" & k, "Name"
colShapes.Add colTemp, "Shape" & k
Else
i = i + 1
colTemp.Add varTemp.Left, "Left"
colTemp.Add varTemp.Top, "Top"
colTemp.Add varTemp.Left + varTemp.Width, "Right"
colTemp.Add varTemp.Top + varTemp.Height, "Bottom"
colTemp.Add "Line" & i, "Name"
colLines.Add colTemp
End If
Next varTemp
For Each varShape In colShapes
' Tempor�re Collection anlegen
Set colChildLine = New Collection
For Each varLine In colLines
With varShape(1)
' Linien finden, bei denen die Bottom-Position direkt
' innerhalb des aktuellen K�stchens beginnt
If (varLine("Top") >= (.Top + 1)) _
And _
(varLine("Top") <= (.Top + .Height + 5)) _
Then
' Linien finden, bei denen die Left-Position direkt
' innerhalb des aktuellen K�stchens beginnt
If (varLine("Left") >= (.Left - 1)) _
And _
(varLine("Left") <= (.Left + .Width + 1)) _
Then
' Passende Linien in tempor�rer Collection
' speichern
colChildLine.Add varLine, varLine("Name")
' Linien finden, bei denen die Right-Position direkt
' innerhalb des aktuellen K�stchens beginnt
ElseIf (varLine("Right") <= (.Left + .Width + 1)) _
And _
(varLine("Right") >= (.Left - 1)) _
Then
' Passende Linien in tempor�rer Collection
' speichern
colChildLine.Add varLine, varLine("Name")
End If
End If
End With
Next varLine
' Tempor�re Collection anlegen
Set colTemp = New Collection
' Als erstes Element das Elternelement in der
' tempor�ren Collection speichern
colTemp.Add varShape(1), "Object"
For Each varLine In colChildLine
For Each varTemp In colShapes
With varTemp(1)
' Linien finden, bei denen die Bottom-Position direkt
' innerhalb des aktuellen K�stchens beginnt
If (varLine("Bottom") <= (.Top + .Height + 1)) _
And _
(varLine("Bottom") >= (.Top - 1)) _
Then
' Linien finden, bei denen die Left-Position direkt
' innerhalb des aktuellen K�stchens beginnt
If (varLine("Left") >= (.Left - 1)) _
And _
(varLine("Left") <= (.Left + .Width + 1)) _
Then
' Kind-Shape in tempor�rer Collection
' speichern
colTemp.Add varTemp(1), varTemp("Name")
' Linien finden, bei denen die Right-Position direkt
' innerhalb des aktuellen K�stchens beginnt
ElseIf (varLine("Right") <= (.Left + .Width + 1)) _
And _
(varLine("Right") >= (.Left - 1)) _
Then
' Kind-Shape in tempor�rer Collection
' speichern
colTemp.Add varTemp(1), varTemp("Name")
End If
End If
End With
Next varTemp
Next varLine
' Anzahl der Kindelemente in tempor�rer Collection speichern
colTemp.Add colTemp.Count - 1, "ChildCount", , 1
' Text der Elemente als Array in tempor�rer Collection
' speichern. Element mit Index Null ist immer ein Leerstring
If colTemp.Count > 2 Then
k = 0
ReDim astrText(colTemp.Count - 2)
For i = 3 To colTemp.Count
k = k + 1
astrText(k) = colTemp(i).TextFrame2.TextRange.Text
Next
Else
ReDim astrText(0)
End If
' Text des Elternshapes als element 0
astrText(0) = varShape(1).TextFrame2.TextRange.Text
' Textarray in tempor�rer Collection speichern
colTemp.Add astrText, "ChildText", , 2
' Tempor�re Collection in Result-Collection speichern
colResult.Add colTemp
Next varShape
' Result-Collection als Funktionsergebnis zur�ckgeben
Set FindChild = colResult
End Function
Zur�ckgegeben wird eine Collection, in der f�r jedes Shape innerhalb des
SmartArt-Objektes ein eigenes Element (weitere Collection) angelegt wird.
Dieses enth�lt als erstes Element einen Objektverweis, als zweites die
Anzahl der Kindelemente, als drittes ein Array ab Index 1 mit den Texten
(Element 0, Text des Elternelements) der Kindelemente. Ab dem vierten
Element folgen die Kindelemente jeweils als Objektverweis.
Du musst also nur noch selbst die zur�ckgegebene Collection auswerten.
Setze am besten erst einmal einen Haltepunkt und schaue dir im Lokalfenster
das Ergebnis an.
Viele Gr��e
Michael
--
Andre
wrote:
> Hallo Andre,
>
> Am Mon,11May200902:37:25-0700(PDT) schrieb Andre:
>
> >>> > Wie das Betreff schon sagt such ich einen Zugang zu den, wie ich
> >>> > das Objekt ist ein Shape, aber ich finde kein Objekt und keine
> >>> > Hntergrund: Ich will beispielsweise ein mittels SmartArt angelegtes
> >>> > Organigramm auslesen.
>
> >>> auslesen kannst du das mit VBA schon, das Setzen der Eigenschaften wird
> >>> aber unterbunden. Ich habe es jedenfalls nicht geschafft, den Text oder
> > Oh - reicht mir doch nicht: Ich habe so meine Schwierigkeiten mit den
> > denn auch raus?
>
> das Problem ist, dass es darin keine Hierachie gibt.
> Alle Shapes, auch die, welche die Verbindungslinien darstellen, sind
> Abhängigkeiten nachzuvollziehen.
> Bei einem Organigramm funktioniert nach ersten Tests folgendes:
>
> Sub testen()
> Dim objShape As Shape
> Dim colResult As Collection
> Set objShape = ActiveSheet.shapes(1)
> Set colResult = FindChild(objShape)
> End Sub
>
> Private Function FindChild(objShape As Shape) As Collection
> Dim colResult As New Collection
> Dim colShapes As New Collection
> Dim colLines As New Collection
> Dim colTemp As Collection
> Dim colChildLine As Collection
>
> Dim varLine As Variant
> Dim varTemp As Variant
> Dim varShape As Variant
> Dim astrText() As String
> Dim i As Long
> Dim k As Long
>
> On Error Resume Next
>
> ' Linien und Formen in jeweils einer eigenen
> ' Collection speichern
> For Each varTemp In objShape.GroupItems
>
> Set colTemp = New Collection
>
> If varTemp.Type <> msoLine Then
> k = k +1
> colTemp.Add varTemp
> colTemp.Add "Shape" & k, "Name"
> colShapes.Add colTemp, "Shape" & k
> Else
> i = i +1
> colTemp.Add varTemp.Left, "Left"
> colTemp.Add varTemp.Top, "Top"
> colTemp.Add varTemp.Left + varTemp.Width, "Right"
> colTemp.Add varTemp.Top + varTemp.Height, "Bottom"
> colTemp.Add "Line" & i, "Name"
> colLines.Add colTemp
> End If
>
> Next varTemp
>
> For Each varShape In colShapes
>
> Set colChildLine = New Collection
>
> For Each varLine In colLines
>
> With varShape(1)
>
> ' Linien finden, bei denen die Bottom-Position direkt
> If (varLine("Top") >= (.Top +1)) _
> And _
> (varLine("Top") <= (.Top + .Height +5)) _
> Then
>
> ' Linien finden, bei denen die Left-Position direkt
> If (varLine("Left") >= (.Left -1)) _
> And _
> (varLine("Left") <= (.Left + .Width +1)) _
> Then
> ' Passende Linien in temporärer Collection
> ' speichern
> colChildLine.Add varLine, varLine("Name")
>
> ' Linien finden, bei denen die Right-Position direkt
> ElseIf (varLine("Right") <= (.Left + .Width +1)) _
> And _
> (varLine("Right") >= (.Left -1)) _
> Then
> ' Passende Linien in temporärer Collection
> ' speichern
> colChildLine.Add varLine, varLine("Name")
> End If
> End If
>
> End With
>
> Next varLine
>
> Set colTemp = New Collection
>
> ' Als erstes Element das Elternelement in der
> colTemp.Add varShape(1), "Object"
>
> For Each varLine In colChildLine
>
> For Each varTemp In colShapes
>
> With varTemp(1)
>
> ' Linien finden, bei denen die Bottom-Position direkt
> If (varLine("Bottom") <= (.Top + .Height +1)) _
> And _
> (varLine("Bottom") >= (.Top -1)) _
> Then
>
> ' Linien finden, bei denen die Left-Position direkt
> If (varLine("Left") >= (.Left -1)) _
> And _
> (varLine("Left") <= (.Left + .Width +1)) _
> Then
> ' speichern
> colTemp.Add varTemp(1), varTemp("Name")
>
> ' Linien finden, bei denen die Right-Position direkt
> ElseIf (varLine("Right") <= (.Left + .Width +1)) _
> And _
> (varLine("Right") >= (.Left -1)) _
> Then
> ' speichern
> colTemp.Add varTemp(1), varTemp("Name")
> End If
> End If
>
> End With
>
> Next varTemp
>
> Next varLine
>
> colTemp.Add colTemp.Count -1, "ChildCount", ,1
>
> ' Text der Elemente als Array in temporärer Collection
> ' speichern. Element mit Index Null ist immer ein Leerstring
> If colTemp.Count >2Then
> k =0
> ReDim astrText(colTemp.Count -2)
> For i =3To colTemp.Count
> k = k +1
> astrText(k) = colTemp(i).TextFrame2.TextRange.Text
> Next
> Else
> ReDim astrText(0)
> End If
>
> ' Text des Elternshapes als element0
> astrText(0) = varShape(1).TextFrame2.TextRange.Text
>
> colTemp.Add astrText, "ChildText", ,2
> colResult.Add colTemp
>
> Next varShape
>
> ' Result-Collection als Funktionsergebnis zurückgeben
> Set FindChild = colResult
>
> End Function
>
> SmartArt-Objektes ein eigenes Element (weitere Collection) angelegt wird.
>
> Anzahl der Kindelemente, als drittes ein Array ab Index1mit den Texten
> Element folgen die Kindelemente jeweils als Objektverweis.
>
> Setze am besten erst einmal einen Haltepunkt und schaue dir im Lokalfenster
> das Ergebnis an.
>
> Michael
>
> --http://michael-schwimmer.de
> Masterclass Excel VBA ISBN-10:3827325250
> Das Excel-VBA Codebook ISBN-10:3827324718
> Microsoft Office Excel2007-Programmierung ISBN-10:3866454139
Das ist stark! Vor allem in der kuzen Zeit!
Danke!
Michael Schwimmer
Am Mon, 11 May 2009 06:56:01 -0700 (PDT) schrieb Andre:
> Das ist stark! Vor allem in der kuzen Zeit!
ich bin zwar schnell (m�de), so schnell aber nun auch nicht.
Ich hatte mich schon am WE damit besch�ftigt und konnte deshalb so
kurzfristig reagieren ;-)
> Danke!
Gern geschehen.
Viele Gr��e
Michael
--