Würfel-Objekt erstellen

.. das wohl mächtigste Werkzeug in Bill Gates' Büro-Sippe. Ob reine Formeln, PowerQuery oder VBA. Hier bleiben kaum Wünsche unerfüllt.
Antworten
xlKing
Beiträge: 30
Registriert: 30. Mai 2024, 19:42
Hat sich bedankt: 2 Mal
Danksagung erhalten: 34 Mal
Kontaktdaten:
Kontaktdaten von xlKing

Würfel-Objekt erstellen

#1

Beitrag von xlKing »

Hallo zusammen,

Ich möchte euch heute zeigen wie man ein Würfel-Objekt erstellt.
Zunächst braucht man ein Klassenmodul dem man z.B. den Namen "Die" gibt. Dort rein kommt folgender Code:

Code: Alles auswählen

Dim iObject As Shape
Dim iValue As Long
Dim iMargin As Single
Dim iEyeSize As Single
Function AddShape(ws As Worksheet, Left As Single, Top As Single, Size As Single) As Shape
  
  Dim c As Long, i As Long
  
  With ws.Shapes
    .AddShape msoShapeRoundedRectangle, Left, Top, Size, Size
    .AddShape msoShapeOval, Left + Size / 2 - 5, Top + Size / 2 - 5, 10, 10
    .AddShape msoShapeOval, Left + Size / 2 - 5, Top + Size / 2 - 5, 10, 10
    .AddShape msoShapeOval, Left + Size / 2 - 5, Top + Size / 2 - 5, 10, 10
    .AddShape msoShapeOval, Left + Size / 2 - 5, Top + Size / 2 - 5, 10, 10
    .AddShape msoShapeOval, Left + Size / 2 - 5, Top + Size / 2 - 5, 10, 10
    .AddShape msoShapeOval, Left + Size / 2 - 5, Top + Size / 2 - 5, 10, 10
    c = .Count
    SetShape .Range(Array(c, c - 1, c - 2, c - 3, c - 4, c - 5, c - 6)).Group
    For i = 2 To 7
      With .Item(.Count).GroupItems(i)
        .Line.Visible = msoFalse
        .Fill.ForeColor.RGB = 125
      End With
    Next i
    Margin = 0.5
    EyeSize = 0.9
    Value = 6
  End With
  
End Function
Property Get Object() As Shape
  Set Object = iObject
End Property
Property Get Color() As Long
  Color = iObject.GroupItems(1).Fill.ForeColor.RGB
End Property
Property Let Color(v As Long)
  iObject.GroupItems(1).Fill.ForeColor.RGB = v
End Property
Property Get EyeColor() As Long
  EyeColor = iObject.GroupItems(2).Fill.ForeColor.RGB
End Property
Property Let EyeColor(v As Long)
  For i = 2 To 7
    iObject.GroupItems(i).Fill.ForeColor.RGB = v
  Next i
End Property
Property Get Margin() As Single
  Margin = iMargin
End Property
Property Let Margin(v As Single)
  'Ein Wert zwischen 0 und 1 wobei 1=100% der maximal möglichen Augengröße (Breite / 3) entspricht.
  iMargin = v
  EyeSize = iEyeSize
End Property
Property Get EyeSize() As Single
  EyeSize = iEyeSize
End Property
Property Let EyeSize(v As Single)
  'Ein Wert zwischen 0 und 1 wobei 1=100% der maximal möglichen Augengröße innerhalb des verfügbaren Bereichs((Breite - 2 * Margin) / 3) ist
  Dim eye As Byte
  For eye = 1 To 6
    iObject.GroupItems(eye + 1).Width = (iObject.GroupItems(1).Width - 2 * iMargin * EyeSpaceWidth) / 3 * v
    iObject.GroupItems(eye + 1).Height = (iObject.GroupItems(1).Height - 2 * iMargin * EyeSpaceWidth) / 3 * v
  Next eye
  iEyeSize = v
  Value = iValue
End Property

Property Get Left() As Single
  Left = iObject.Left
End Property
Property Let Left(v As Single)
  iObject.Left = v
End Property
Property Get Top() As Single
  Top = iObject.Top
End Property
Property Let Top(v As Single)
  iObject.Top = v
End Property

Property Get Width() As Single
  Width = iObject.Width
End Property
Property Let Width(v As Single)
  iObject.Width = v
  iObject.Height = v
End Property
Property Get Height() As Single
  Height = iObject.Height
End Property
Property Let Height(v As Single)
  iObject.Width = v
  iObject.Height = v
End Property

Friend Sub SetShape(shp As Shape)
  Set iObject = shp
End Sub
Property Get Value() As Long
  Value = iValue
End Property

Property Let Value(v As Long)
  Dim eye As Byte
  iValue = v
  For eye = 1 To 6
    iObject.GroupItems(eye + 1).Visible = msoFalse
  Next eye
  Select Case v
  Case 1
    With iObject.GroupItems(2)
        .Visible = msoTrue
        .Left = iObject.GroupItems(1).Left + iObject.GroupItems(1).Width / 2 - .Width / 2
        .Top = iObject.GroupItems(1).Top + iObject.GroupItems(1).Height / 2 - .Height / 2
    End With
  Case 2
    With iObject.GroupItems(2)
        .Visible = msoTrue
        .Left = iObject.GroupItems(1).Left + iMargin * EyeSpaceWidth
        .Top = iObject.GroupItems(1).Top + iMargin * EyeSpaceWidth
    End With
    With iObject.GroupItems(3)
        .Visible = msoTrue
        .Left = iObject.GroupItems(1).Left + iObject.GroupItems(1).Width - iMargin * EyeSpaceWidth - .Width
        .Top = iObject.GroupItems(1).Top + iObject.GroupItems(1).Height - iMargin * EyeSpaceWidth - .Height
    End With
  Case 3
    With iObject.GroupItems(2)
        .Visible = msoTrue
        .Left = iObject.GroupItems(1).Left + iMargin * EyeSpaceWidth
        .Top = iObject.GroupItems(1).Top + iMargin * EyeSpaceWidth
    End With
    With iObject.GroupItems(3)
        .Visible = msoTrue
        .Left = iObject.GroupItems(1).Left + iObject.GroupItems(1).Width - iMargin * EyeSpaceWidth - .Width
        .Top = iObject.GroupItems(1).Top + iObject.GroupItems(1).Height - iMargin * EyeSpaceWidth - .Height
    End With
    With iObject.GroupItems(4)
       .Visible = msoTrue
       .Left = iObject.GroupItems(1).Left + iObject.GroupItems(1).Width / 2 - .Width / 2
       .Top = iObject.GroupItems(1).Top + iObject.GroupItems(1).Height / 2 - .Height / 2
    End With
  Case 4
    With iObject.GroupItems(2)
        .Visible = msoTrue
        .Left = iObject.GroupItems(1).Left + iMargin * EyeSpaceWidth
        .Top = iObject.GroupItems(1).Top + iMargin * EyeSpaceWidth
    End With
    With iObject.GroupItems(3)
        .Visible = msoTrue
        .Left = iObject.GroupItems(1).Left + iObject.GroupItems(1).Width - iMargin * EyeSpaceWidth - .Width
        .Top = iObject.GroupItems(1).Top + iObject.GroupItems(1).Height - iMargin * EyeSpaceWidth - .Height
    End With
    With iObject.GroupItems(4)
        .Visible = msoTrue
        .Left = iObject.GroupItems(1).Left + iObject.GroupItems(1).Width - iMargin * EyeSpaceWidth - .Width
        .Top = iObject.GroupItems(1).Top + iMargin * EyeSpaceWidth
    End With
    With iObject.GroupItems(5)
        .Visible = msoTrue
        .Left = iObject.GroupItems(1).Left + iMargin * EyeSpaceWidth
        .Top = iObject.GroupItems(1).Top + iObject.GroupItems(1).Height - iMargin * EyeSpaceWidth - .Height
    End With
  Case 5
    With iObject.GroupItems(2)
        .Visible = msoTrue
        .Left = iObject.GroupItems(1).Left + iMargin * EyeSpaceWidth
        .Top = iObject.GroupItems(1).Top + iMargin * EyeSpaceWidth
    End With
    With iObject.GroupItems(3)
        .Visible = msoTrue
        .Left = iObject.GroupItems(1).Left + iObject.GroupItems(1).Width - iMargin * EyeSpaceWidth - .Width
        .Top = iObject.GroupItems(1).Top + iObject.GroupItems(1).Height - iMargin * EyeSpaceWidth - .Height
    End With
    With iObject.GroupItems(4)
        .Visible = msoTrue
        .Left = iObject.GroupItems(1).Left + iObject.GroupItems(1).Width - iMargin * EyeSpaceWidth - .Width
        .Top = iObject.GroupItems(1).Top + iMargin * EyeSpaceWidth
    End With
    With iObject.GroupItems(5)
        .Visible = msoTrue
        .Left = iObject.GroupItems(1).Left + iMargin * EyeSpaceWidth
        .Top = iObject.GroupItems(1).Top + iObject.GroupItems(1).Height - iMargin * EyeSpaceWidth - .Height
    End With
    With iObject.GroupItems(6)
       .Visible = msoTrue
       .Left = iObject.GroupItems(1).Left + iObject.GroupItems(1).Width / 2 - .Width / 2
       .Top = iObject.GroupItems(1).Top + iObject.GroupItems(1).Height / 2 - .Height / 2
    End With
  Case 6
    With iObject.GroupItems(2)
        .Visible = msoTrue
        .Left = iObject.GroupItems(1).Left + iMargin * EyeSpaceWidth
        .Top = iObject.GroupItems(1).Top + iMargin * EyeSpaceWidth
    End With
    With iObject.GroupItems(3)
        .Visible = msoTrue
        .Left = iObject.GroupItems(1).Left + iObject.GroupItems(1).Width - iMargin * EyeSpaceWidth - .Width
        .Top = iObject.GroupItems(1).Top + iObject.GroupItems(1).Height - iMargin * EyeSpaceWidth - .Height
    End With
    With iObject.GroupItems(4)
        .Visible = msoTrue
        .Left = iObject.GroupItems(1).Left + iObject.GroupItems(1).Width - iMargin * EyeSpaceWidth - .Width
        .Top = iObject.GroupItems(1).Top + iMargin * EyeSpaceWidth
    End With
    With iObject.GroupItems(5)
        .Visible = msoTrue
        .Left = iObject.GroupItems(1).Left + iMargin * EyeSpaceWidth
        .Top = iObject.GroupItems(1).Top + iObject.GroupItems(1).Height - iMargin * EyeSpaceWidth - .Height
    End With
    With iObject.GroupItems(6)
       .Visible = msoTrue
       .Left = iObject.GroupItems(1).Left + iMargin * EyeSpaceWidth
       .Top = iObject.GroupItems(1).Top + iObject.GroupItems(1).Height / 2 - .Height / 2
    End With
    With iObject.GroupItems(7)
       .Visible = msoTrue
       .Left = iObject.GroupItems(1).Left + iObject.GroupItems(1).Width - iMargin * EyeSpaceWidth - .Width
       .Top = iObject.GroupItems(1).Top + iObject.GroupItems(1).Height / 2 - .Height / 2
    End With
    
  End Select
  
  
End Property

Property Get Name() As String
  Name = iObject.Name
End Property
Property Let Name(v As String)
  iObject.Name = v
End Property
Private Function EyeSpaceWidth()
  EyeSpaceWidth = iObject.GroupItems(1).Width / 3
End Function
Anschließend kann man in einem Standardmodul z.B. folgenden Code verwenden:

Code: Alles auswählen

Dim wfl As New Die
  
Sub Test()

  
  wfl.AddShape ActiveSheet, 50, 50, 50
  Debug.Print wfl.Width
  Debug.Print wfl.Object.GroupItems(1).Width
  
End Sub
Sub Test2()

  With wfl
    .SetShape ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
    .Margin = 0.6
    .EyeSize = 0.8
    .Value = 3
    .Color = 255
    .EyeColor = RGB(255, 255, 255)
  End With
  
End Sub
Sub Wuerfeln()
  
  Dim Start As Single, start2 As Single, sek As Single
  
  wfl.SetShape ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
  
  Randomize Timer
  sek = Int(Rnd * 5) + 1
  
  Start = Timer
  
  Do
    wfl.Value = Int(Rnd * 6) + 1
    start2 = Timer
    Do
      DoEvents
    Loop Until Timer >= start2 + 0.1 Or Timer < start2
  Loop Until Timer >= Start + sek Or Timer < Start
  
End Sub
Zunächst muss man einmalig das erste Makro (Test) ausführen. um ein Würfel-Objekt zu erstellen. Wenn das Shape bereits existiert und man nur Änderungen an den Eigenschaften vornehmen will kann man stattdessen das zweite Makro (Test2) ausführen. Das Dritte Makro (Wuerfeln) zeigt, wie man einige Zufallswürfe innerhalb eines zuvor zufällig gewählten Zeitraums (zwischen 1 und 5 Sekunden) erzeugt, damit man auch sieht dass der Digitale Würfel sich verändert. Will man den Effekt noch verstärken, kann man das gesamte Objekt innerhalb der Zeit auch noch über den Bildschirm bewegen. Das überlasse ich dann euch.

Wichtig ist, dass dem Die-Objekt immer ein entsprechendes Shape zugeordnet ist. Das erreicht man entweder mit AddShape oder mit SetShape. Alle anderen Eigenschaften sind selbsterklärend.

PS: Da ich die Formatierungen des Objekts hier über eigene Eigenschaften mache, habe ich AddShape hier nicht als Funktion sondern als Sub-Befehl verwendet. Man kann Funktionen nämlich auch als normale Befehle ohne Rückgabewert ausführen.

Gruß Mr. K.
Folgende Benutzer bedankten sich beim Autor xlKing für den Beitrag (Insgesamt 2):
thowe, d'r Bastler
Nach oben
Benutzeravatar
d'r Bastler
Beiträge: 670
Registriert: 29. Aug 2022, 13:20
Hat sich bedankt: 175 Mal
Danksagung erhalten: 90 Mal

Re: Würfel-Objekt erstellen

#2

Beitrag von d'r Bastler »

Moin Mr. K.
also, dass du hier nicht mit VBAnfänger-Fragen einreisen wirst, wusste ich ja bereits. Dass Du aber gleich mit solch einem High-Quality-Projekt aufschlägst, ist natürlich der Knüller!
Herzlichen Dank dafür! und laut und deutlich das versprochene Herzlich Willkommen!
d'r Bastler von den VBAsteleien.de
Win 10 + Office 2019 & Win11 + Office 2021 + Visio 2019 pro & macOS.X15 + Office2019pro & Android12 & XL365
Nach oben
Antworten

Zurück zu „Microsoft Excel“

Wer ist online?

Mitglieder in diesem Forum: Ahrefs [Bot] und 0 Gäste