Shape in GroupShape mit Namen ansprechen
24.10.2013 14:35:26
Reinhard
nachstehend ist der gesamte Code. Er funktioniert bis auf das was ich hier anfrage zuverlässig. Viermal erzeugt er jeweils als Shape ein Quadrat namens Rene_Quadrat und ein Dreieck namens Rene_Dreieck.
Beide Shapes werden dann zu einem Shape gruppiert namens Rene_Pfeillinks, Rene_Pfeillinks, usw., halt die vier Richtungen.
Bis dahin läuft alles wunderbar.
With wks 'das aktivesheet
'
' Derfunktionierende Codeteil.
'
MsgBox "-" & .Shapes("Rene_Pfeilrechts").GroupItems(2).Name & "-"
strName = .Shapes("Rene_Pfeilrechts").GroupItems(2).Name
MsgBox strName
MsgBox .Shapes("Rene_Pfeilrechts").GroupItems(2).Fill.ForeColor.SchemeColor
MsgBox .Shapes("Rene_Pfeilrechts").GroupItems(strName).Fill.ForeColor.SchemeColor
MsgBox .Shapes("Rene_Pfeilrechts").GroupItems("Rene_Dreieck").Fill.ForeColor.SchemeColor
Was ich fett markiert habe sind die Codezeilen wo Laufzeitfehler xxxxxxxx kommt mit Fehlertext: "Der angegebene Wert ist außerhalb des zulässigen Bereichs."
Zigfach überprüft, auch im VBE-Lokalfenster, .GroupItems(2) heißt eindeutig
"Rene_Dreieck". strName zeigt mir das ja auch an.
Wie überrede ich Vba damit ich anstatt .GroupItems(2), .GroupItems("Rene_Dreieck")
benutzen kann?
Achja, ich will nur die Farbe des Dreiecks ändern, nix kompliziertes.
Nachstehend halt der komplette Code, läuft problemlos in jedem Standardmodul
bis zur Fehlerstelle. Deshalb keine Beispielmappe, leeres Blatt habt ihr ja wohl :-)
Gruß ^ Danke
Reinhard
Option Explicit
Sub tt()
Dim S As Shape, wks As Worksheet, strName As String
Set wks = ActiveSheet
With wks
For Each S In .Shapes
If S.Name Like "Rene*" Then S.Delete
Next S
Call PfeilErzeugen(Range("B2"), "rauf")
Call PfeilErzeugen(Range("B3"), "runter")
Call PfeilErzeugen(Range("B4"), "links")
Call PfeilErzeugen(Range("B5"), "rechts")
Set S = .Shapes("Rene_Pfeilrechts") '.GroupItems("Rene_Dreieck")
' For Each S In .Shapes
' If S.Name Like "Rene*" Then MsgBox S.Name
' Next S
MsgBox "-" & .Shapes("Rene_Pfeilrechts").GroupItems(2).Name & "-"
strName = .Shapes("Rene_Pfeilrechts").GroupItems(2).Name
MsgBox strName
MsgBox .Shapes("Rene_Pfeilrechts").GroupItems(2).Fill.ForeColor.SchemeColor
MsgBox .Shapes("Rene_Pfeilrechts").GroupItems(strName).Fill.ForeColor.SchemeColor
MsgBox .Shapes("Rene_Pfeilrechts").GroupItems("Rene_Dreieck").Fill.ForeColor.SchemeColor
'.Shapes("Rene_Pfeilrechts").GroupItems("Rene_Dreieck").Fill.ForeColor.SchemeColor = 3
End With
End Sub
Sub PfeilErzeugen(ByRef rngZelle As Range, ByVal strRichtung As String)
Dim N As Integer, S As Shape, wks As Worksheet
Set wks = ActiveSheet
With wks
' For Each S In .Shapes
' If S.Name = "Rene_Quadrat" Then S.Delete
' If S.Name = "Rene_Dreieck" Then S.Delete
' If S.Name = "Rene_PfeilRunter" Then S.Delete
' Next S
With rngZelle
Set S = wks.Shapes.AddShape(msoShapeRectangle, .Left, .Top, 10, 10)
End With
With S
.Name = "Rene_Quadrat"
.Fill.Visible = msoTrue
.Fill.Solid
.Fill.ForeColor.SchemeColor = 45
.Fill.Transparency = 0#
.Line.Weight = 0.75
.Line.DashStyle = msoLineSolid
.Line.Style = msoLineSingle
.Line.Transparency = 0#
.Line.Visible = msoTrue
.Line.ForeColor.SchemeColor = 64
.Line.BackColor.RGB = RGB(255, 255, 255)
End With
With .Shapes("Rene_Quadrat")
Set S = wks.Shapes.AddShape(msoShapeIsoscelesTriangle, .Left + 2, .Top + 3, .Width - 4, . _
Height - 6)
End With
With S
.Name = "Rene_Dreieck"
.Fill.Visible = msoTrue
.Fill.Solid
.Fill.ForeColor.SchemeColor = 8
.Fill.Transparency = 0#
.Line.Weight = 0.75
.Line.DashStyle = msoLineSolid
.Line.Style = msoLineSingle
.Line.Transparency = 0#
.Line.Visible = msoTrue
.Line.ForeColor.SchemeColor = 64
.Line.BackColor.RGB = RGB(255, 255, 255)
End With
Set S = .Shapes.Range(Array("Rene_Quadrat", "Rene_Dreieck")).Group
S.Name = "Rene_Pfeil" & strRichtung
Select Case strRichtung
Case "rauf"
.Shapes("Rene_Pfeil" & strRichtung).Rotation = 0
Case "runter"
.Shapes("Rene_Pfeil" & strRichtung).Rotation = 180
Case "links"
.Shapes("Rene_Pfeil" & strRichtung).Rotation = 270
Case "rechts"
.Shapes("Rene_Pfeil" & strRichtung).Rotation = 90
Case Else
MsgBox "Richtung falsch"
End Select
End With
End Sub