Shape in vba ansprechen

28/06/2010 - 11:06 von Thomas Kühn | Report spam
Hallo,
ich sitze hier vor folgendem Problem und hoffentlich kann jemand
helfen:
In einem Sheet habe ich eine Gruppierung mit mehreren Objekten.
Diese Gruppierung möchte ich in vba ansprechen. Dazu habe ich einen
Namen definiert ("StatusLights").
Das Problem ist nun, dass die Gruppe in einer Schleife mit den Namen
einmal erkannt wird, ein anderes mal nicht.
Der vba Code steht in Access, daraus befülle ich das Sheet. Das Excel
Object bleibt das gleiche.
Woran kann das liegen?

Excel Version ist 2002, Windows XP Prof SP 2


Gruß Thomas

http://www.thomas-kuehn.de
 

Lesen sie die antworten

#1 Andreas Killer
28/06/2010 - 17:27 | Warnen spam
Am 28.06.2010 11:06, schrieb Thomas Kühn:

ich sitze hier vor folgendem Problem und hoffentlich kann jemand
helfen:


Schaun wir mal...

In einem Sheet habe ich eine Gruppierung mit mehreren Objekten.
Diese Gruppierung möchte ich in vba ansprechen. Dazu habe ich einen
Namen definiert ("StatusLights").
Das Problem ist nun, dass die Gruppe in einer Schleife mit den Namen
einmal erkannt wird, ein anderes mal nicht.
Der vba Code steht in Access, daraus befülle ich das Sheet. Das Excel
Object bleibt das gleiche.


Ohne den Code zu sehen kann man nicht viel sagen, nur: Es wird wohl
ein Programmierfehler sein. .-)

Ich weiß ja nicht was Du machen willst, wenn Du die Steuerelemente
ansprechen möchtest, dann empfehle ich die Function GetShapeObj, die
sammelt Dir alles zusammen was Du möchtest, egal ob gruppiert oder nicht.

Andreas.

'Version 2.0
Option Explicit
Option Compare Text
Option Private Module

Private Sub Example_GetShapeObj()
'Ein Beispiel wenn man nur einmal suchen möchte

Const SearchString = "*" 'Suche alle

Dim Obj As Object, Sh As Shape
Dim LastName As String, LastCaption As String, Alle As String

'Suche das erste Objekt (LastName ist jetzt "")
Set Obj = GetShapeObj(SearchString, LastName, LastCaption)

'Was gefunden?
Do While Not Obj Is Nothing
'Namen und Titel/Inhalt/Bezeichnung merken
Alle = Alle & LastName & " : " & LastCaption & vbCrLf

'Über den Namen kann man sich bei Bedarf auch das Shape holen
Set Sh = ActiveSheet.Shapes(LastName)

'Suche das nàchste Objekt
Set Obj = GetShapeObj(SearchString, LastName, LastCaption)
Loop
MsgBox Alle
End Sub

Private Sub Example_GetShapeObj_Dictionary()
'Ein Beispiel wenn man alle Objekte zusammengefasst haben _
möchte
Dim Alle As String
Dim Dict As Object
Dim Items(), Keys(), I As Long

'Suche alle Buttons/CommandButtons
Set Dict = GetShapeObj("*button*", ReturnDictionary:=True)

'Lese die Objekte in ein Array
Items = Dict.Items
'Lese die Namen in ein Array
Keys = Dict.Keys

For I = LBound(Items) To UBound(Items)
'Namen und Titel/Inhalt/Bezeichnung merken
Alle = Alle & Keys(I) & " : " & Items(I).Caption & vbCrLf
Next
MsgBox Alle
End Sub

Private Sub Example_GetShapeObj_Type()
'Ein Beispiel wenn man nur bestimmte Typen zusammengefasst _
haben möchte

Dim Obj As Object
Dim Alle As String
Dim Buttons As Object, CommandButtons As Object, Charts As _
Object
Dim Items(), Keys(), I As Long

Alle = "Name : Caption" & vbCrLf

'Suche alle Befehlsschaltflàchen
'(ProgId = "Forms.CommandButton.1")
Set CommandButtons = GetShapeObj("*", _
ShapeType:=msoOLEControlObject, _
ProgId:="*commandbutton*", _
ReturnDictionary:=True)
Set Obj = CommandButtons
Alle = Alle & vbCrLf & "***CommandButtons***" & vbCrLf
GoSub ListButtons

'Suche alle Schaltflàchen (z.B. "Button 1")
Set Buttons = GetShapeObj("*", _
ShapeType:=msoFormControl, _
ProgId:=xlButtonControl, _
ReturnDictionary:=True)
Set Obj = Buttons
Alle = Alle & vbCrLf & "***Buttons***" & vbCrLf
GoSub ListButtons

'Suche alle Diagramme
Set Charts = GetShapeObj("*", , , msoChart, , True)
Items = Charts.Items
Keys = Charts.Keys
Alle = Alle & vbCrLf & "***Charts***" & vbCrLf
For I = LBound(Items) To UBound(Items)
Alle = Alle & Keys(I) & " : " & Items(I).ChartTitle.Text & _
vbCrLf
Next
MsgBox Alle
Exit Sub

ListButtons:
'Lese die Objekte in ein Array
Items = Obj.Items
'Lese die Namen in ein Array
Keys = Obj.Keys

For I = LBound(Items) To UBound(Items)
'Namen und Bezeichnung merken
Alle = Alle & Keys(I) & " : " & Items(I).Caption & vbCrLf
Next
Return
End Sub

Function GetShapeObj(ByVal NameOrCaption As String, _
Optional LastName As String = "", _
Optional LastCaption As String = "", _
Optional ShapeType As MsoShapeType = 0, _
Optional ProgId As Variant, _
Optional ReturnDictionary As Boolean = False, _
Optional ParseGroups As Boolean = True, _
Optional WS As Worksheet = Nothing) As Object

'Liefert das Object NameOrCaption im Sheet WS für den _
direkten Zugriff, auch für (mehrfach-) gruppierte Objekte _
wenn ParseGroups = True, Nothing wenn nicht gefunden.
'Wenn LastName <> "" angegeben wird, dann wird eine _
begonnene Suche fortgesetzt und das nàchste Objekt nach _
LastName geliefert.
'LastCaption wird nur vom gefundenen Objekt gesetzt, aber _
nicht ausgewertet.
'Wenn ShapeType <> 0, dann werden nur Objekte dieses Typs _
geliefert, hierbei kann optional ein Subtyp mit ProgId _
spezifiziert werden.
'Wenn ReturnDictionary, dann werden alle Objekte gesucht und _
in einem Dictionary zurückgeben.

Dim Sh As Shape, Obj As Object
Dim Found As Boolean, Second As Boolean, Ok As Boolean
Dim Caption As String, Name As String
Dim Coll As New Collection, Dict As Object, I As Long

If WS Is Nothing Then Set WS = ActiveSheet

If ReturnDictionary Then
Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = vbTextCompare
GoTo SearchIt
ElseIf Len(LastName) > 0 Then
'Eine Suche fortsetzen
GoTo SearchIt
Else
'Sofort das erste Object liefern
Second = True
End If

'Direkten Zugriff auf das Object versuchen
On Error Resume Next
Set Sh = WS.Shapes(NameOrCaption)
On Error GoTo 0
'Gefunden?
If Not Sh Is Nothing Then
Set Obj = Sh
GoSub TestShapeType
If Ok Then
'Nur noch auswerten
Found = True
GoTo GotIt
Else
GoTo SearchIt
End If
End If

SearchIt:
'Alle Shapes aufnehmen, wegen mögl. Gruppierungen!
For Each Sh In WS.Shapes
Set Obj = Sh
GoSub TestShapeType
If Ok Then Coll.Add Sh
Next

'Nach dem Shape suchen
I = 1
Do While I <= Coll.Count
Set Sh = Coll.Item(I)
GotIt:
'Was für ein Shapetyp ist es?
Name = Sh.Name
Select Case Sh.Type
Case msoOLEControlObject
Set Obj = Sh.OLEFormat.Object.Object
Caption = Obj.Caption
Case msoPicture, msoLine, msoAutoShape, msoFreeform
Set Obj = Sh.OLEFormat.Object
'Nur manche haben eine Caption!
On Error Resume Next
Caption = ""
Caption = Obj.Caption
On Error GoTo 0
Case msoChart
Set Obj = Sh.OLEFormat.Object.Chart
Caption = Obj.ChartTitle.Caption
Case msoTextEffect
Set Obj = Sh.TextEffect
Caption = Obj.Text
Case msoFormControl, msoComment, msoTextBox
Set Obj = Sh.OLEFormat.Object
Caption = Obj.Caption
Case msoCallout
Set Obj = Sh.Callout
Caption = Sh.OLEFormat.Object.Caption
Case msoEmbeddedOLEObject, msoLinkedOLEObject, _
msoLinkedPicture
Set Obj = Sh.OLEFormat.Object
Caption = ""
Case msoGroup
If ParseGroups Then
'Die einzelnen Objekte der Gruppe hinzufügen
For Each Obj In Sh.GroupItems
GoSub TestShapeType
If Ok Then Coll.Add Obj
Next
'Nàchstes Shape
GoTo NextShape
Else
'Die Gruppe hinzufügen
Set Obj = Sh.GroupItems
Caption = ""
End If
Case Else
Set Obj = Sh
Caption = ""
End Select

'Stimmt (die Caption oder der Name) oder war ein _
Direktzugriff erfolgreich ?
If (Caption Like NameOrCaption And Len(Caption) > 0) Or _
Name Like NameOrCaption Or Found Then
'Alle Objecte zurückgeben?
If ReturnDictionary Then
'Ja, Object und Namen hinzufügen
Dict.Add Name, Obj
Else
'Vorheriges Objekt gefunden?
If Second Then
Set GetShapeObj = Obj
LastName = Name
LastCaption = Caption
Exit Function
End If
If LastName = Name Then Second = True
End If
End If

NextShape:
I = I + 1
Loop

If ReturnDictionary Then Set GetShapeObj = Dict
LastName = ""
LastCaption = ""
Exit Function

TestShapeType:
If ShapeType = 0 Or (Obj.Type = msoGroup And ParseGroups) Then
'Kein Typ gefordert, alle ok
Ok = True
Else
'Falschen Typ annehmen
Ok = False
'Type richtig?
If Obj.Type = ShapeType Then
If IsMissing(ProgId) Then
'Alle Subtypen ok
Ok = True
Else
'Subtyp testen
On Error GoTo WrongType
If VarType(ProgId) = vbString Then
Ok = Obj.OLEFormat.ProgId Like ProgId
Else
Ok = Obj.FormControlType = ProgId
End If
End If
End If
End If
WrongType:
On Error GoTo 0
Return
End Function

Ähnliche fragen