Objekte erstellen und gruppieren
15.11.2013 08:46:12
Andi
ich versuche schon Weile eine via VBA erstellte Ampel zu gruppieren. Die Gruppe benötige ich, weil der Anwender die gesamte Ampel bei Ersterstellung auf dem Blatt korrekt positionieren muss.
habe es auf versch. Arten probiert, jedoch keinen Erfolg. Kann mir jemand bitte einen Tipp geben?
Ich möchte die einzelnen Farben (Kreise) in Variablen belassen, da ich in der Folge via VBA ein automatisches Umschalten einbauen will. Die Ampel befindet sich auf einer Blattvorlage die immer wieder als Basisblatt kopiert wird, um neue Blätter zu erhalten.
DANKE
Sub baueeineampel()
' Ampel erstellen
Dim rot As Shape
Dim gelb As Shape
Dim green As Shape
Dim rah As Shape ' Rahmen
Dim ampel As Shape ' Gruppierung
Set rah = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 98, 98, 32, 92)
rah.Fill.ForeColor.RGB = RGB(255, 255, 255)
rah.LockAspectRatio = msoTrue
Set rot = ActiveSheet.Shapes.AddShape(msoShapeOval, 100, 100, 28, 28)
rot.Fill.ForeColor.RGB = RGB(255, 0, 0)
rot.LockAspectRatio = msoTrue
Set gelb = ActiveSheet.Shapes.AddShape(msoShapeOval, 100, 130, 28, 28)
gelb.Fill.ForeColor.RGB = RGB(255, 255, 0)
gelb.LockAspectRatio = msoTrue
Set green = ActiveSheet.Shapes.AddShape(msoShapeOval, 100, 160, 28, 28)
green.Fill.ForeColor.RGB = RGB(0, 255, 0)
green.LockAspectRatio = msoTrue
' # # # # # # # # P R O B L E M # # # # # # # #
' Gruppierung Versuch 1
ActiveSheet.Shapes.Range(Array("rah", "rot", "gelb", "green")).Group
End Sub
Hier der vorläufige Code für das Umschalten der Ampel:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Address = "$JF$1" Then
Select Case Range("JF1")
Case 1 ' rot
ActiveSheet.Shapes.Range(Array("rot")).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Solid
End With
ActiveSheet.Shapes.Range(Array("gelb")).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
ActiveSheet.Shapes.Range(Array("green")).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
Case 2 ' gelb
ActiveSheet.Shapes.Range(Array("rot")).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
ActiveSheet.Shapes.Range(Array("gelb")).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 0)
.Transparency = 0
.Solid
End With
ActiveSheet.Shapes.Range(Array("green")).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
Case 3 ' grün
ActiveSheet.Shapes.Range(Array("rot")).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
ActiveSheet.Shapes.Range(Array("gelb")).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
ActiveSheet.Shapes.Range(Array("green")).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(146, 208, 80)
.Transparency = 0
.Solid
End With
End Select
End If
Range("JF1").Select
End Sub
Anzeige