VBA Excel ein Puzzle Spiel programmieren

VBA Excel ein Puzzle Spiel programmieren

Author D.Selzer-McKenzie

Video: https://youtu.be/xnHIN0XLpEw

Hier zeige ich Ihnen, wie Sie mit VBA-Excel ein umfangreiches Puzzlespiel programmieren können. Natürlich kann das Spiel mit erheblich weiteren Elementen ausgestattet werden. Schauen Sie sich auf dem Video die Funktionsweise an.

Den Source-Code können Sie im Forum

http://Outbackbrumby.Blogspot.com

herunterladen.

 

Hier der SourceCode VBA:

Public Sub MixPuzzle()

   Dim varRandom  As Variant

   Dim strPath    As String

   Dim lngNumber  As Long

   Dim lngRow     As Long

   Dim lngCol     As Long

   Dim pic        As Picture

 

  

   ' Bildschirmaktualisierung ausschalten

   Application.ScreenUpdating = False

  

   ' Zufallszahlen von 1 bis 9 in Datenfeld laden

   varRandom = GetRandom(lngNumbers:=9)

  

   ' Speicherpfad der Puzzle Bilder

   strPath = ThisWorkbook.Path & "\Puzzle"

  

   ' Alle Grafiken auf Tabellenblatt löschen

   ActiveSheet.Pictures.Delete

  

   ' Bilder an Zellen übergeben

   ' Zeile 5 bis 7

   For lngRow = 5 To 7

  

      ' Spalte 1 bis 3

      For lngCol = 1 To 3

     

         ' Dateiname für Grafik zusammensetzen und Bild einfügen

         ' lngNumber beginnt bei 0 = erstes Datenfeld Element

         Set pic = ActiveSheet.Pictures.Insert _

                   (strPath & varRandom(lngNumber) & ".jpg")

        

         ' Ansichtsverhältnis sperren

         pic.ShapeRange.LockAspectRatio = msoFalse

        

         ' Grafik nach Zufallszahlen benennen

         pic.Name = "Pingu_" & varRandom(lngNumber)

        

         ' ' Grafik an Zellgröße anpassen

         With ActiveSheet.Cells(lngRow, lngCol)

            pic.Left = .Left

            pic.Top = .Top

            pic.Height = .Height

            pic.Width = .Width

         End With

           

         ' Bildnummer um 1 erhöhen

         lngNumber = lngNumber + 1

        

      ' nächste Spalte

      Next lngCol

     

   ' nächste Zeile

   Next lngRow

  

   ' Bildschirmaktualisierung einschalten

   Application.ScreenUpdating = True

End Sub

Public Sub Random()

   Dim colRandom  As New Collection

   Dim lngCounter As Long

   Dim lngC       As Long

  

   ' Schleife um 9 Zahlen zu generieren

   For lngCounter = 1 To 9

  

      ' Schleife um eine neue Zufallszahl zu generieren

      Do

         ' Zufallszahl zwischen 1 und 9 erzeugen

         lngC = Int(Rnd() * 9) + 1

        

         ' Err-Objekt leeren

         Err.Clear

        

         ' Fehlerbehandlungsroutine, um mögliche Fehlermeldung

         ' bei doppelter Zuweisung an Collection abzufangen

         On Error Resume Next

        

         ' Zufallszahl an Collection übergeben

         ' Eindeutiger Key als Text übergeben

         colRandom.Add Item:=lngC, Key:="MB" & lngC

        

      ' Schleife so lange ausführen, bis kein Fehler

      ' mehr bei Zuweisung an Collection erfolgt ist

      Loop Until Err.Number = 0

  

   ' nächste Zufallszahl

   Next lngCounter

  

   ' Meldungsfenster mit allen Zufallszahlen aus Collection

   MsgBox colRandom(1) & vbNewLine & _

          colRandom(2) & vbNewLine & _

          colRandom(3) & vbNewLine & _

          colRandom(4) & vbNewLine & _

          colRandom(5) & vbNewLine & _

          colRandom(6) & vbNewLine & _

          colRandom(7) & vbNewLine & _

          colRandom(8) & vbNewLine & _

          colRandom(9)

End Sub

 

Public Sub Test_GetRandom()

   Dim varArray As Variant

 

   ' Funktion aufrufen um 9 Zufallszahlen zu generieren

   varArray = GetRandom(9)

  

   ' Anzeige der ersten Zufallszahl aus Datenfeld

   MsgBox "erste Zufallszahl: " & varArray(0)

   ' oder

   MsgBox "erste Zufallszahl: " & varArray(LBound(varArray))

  

   ' Anzeige der letzten Zufallszahl aus Datenfeld

   MsgBox "letzte Zufallszahl: " & varArray(UBound(varArray))

End Sub

 

Public Function GetRandom(ByVal lngNumbers As Long) As Variant

   Dim varDummy() As Variant

   Dim colRandom  As New Collection

   Dim lngCounter As Long

   Dim lngC       As Long

  

   ' Datenfeld initialisieren

   ' Anzahl Elemente 1 weniger, weil Datenfeld 0 basierend ist

   ReDim varDummy(lngNumbers - 1)

  

   ' Schleife um Zahlen zu generieren

   For lngCounter = 0 To UBound(varDummy)

  

      ' Schleife um eine neue Zufallszahl zu generieren

      Do

         ' Zufallszahl zwischen 1 und Endzahl erzeugen

         lngC = Int(Rnd() * lngNumbers) + 1

         

         ' Err-Objekt leeren

         Err.Clear

        

         ' Fehlerbehandlungsroutine, um mögliche Fehlermeldung

         ' bei doppelter Zuweisung an Collection abzufangen

         On Error Resume Next

        

         ' Zufallszahl an Collection übergeben

         ' Eindeutiger Key als Text übergeben

         colRandom.Add Item:=lngC, Key:="MB" & lngC

        

      ' Schleife so lange ausführen, bis kein Fehler

      ' mehr bei Zuweisung an Collection erfolgt ist

      Loop Until Err.Number = 0

     

      ' Zufallszahl an Datenfeld übergeben

      varDummy(lngCounter) = lngC

  

   ' nächste Zufallszahl

   Next lngCounter

  

   ' temporäres Datenfeld an Funktion zuweisen

   GetRandom = varDummy

End Function

Public Sub SolvePuzzle()

   Dim rngPic  As Range

   Dim lngPic  As Long

   Dim pic     As Picture

  

   ' Bildschirmaktualisierung ausschalten

   Application.ScreenUpdating = False

  

   ' Bereich der einzufügenden Einzelbilder

   Set rngPic = ActiveSheet.Range("A1:C3")

  

   ' Alle vorhandenen Bilder nach Nummerierung

   ' in Zielbereich einfügen

   For lngPic = 1 To rngPic.Cells.Count

  

      ' Verweis auf nummerierte Grafik

      Set pic = ActiveSheet.Pictures("Pingu_" & lngPic)

     

      ' Grafik an Zellgröße anpassen

      With rngPic.Cells(lngPic)

         pic.Left = .Left

         pic.Top = .Top

         pic.Height = .Height

         pic.Width = .Width

      End With

   Next lngPic

 

   ' Bildschirmaktualisierung einschalten

   Application.ScreenUpdating = True

End Sub

Public Sub Test_GetRandom()

   Dim varArray As Variant

 

   ' Funktion aufrufen um 9 Zufallszahlen zu generieren

   varArray = GetRandom(9)

  

   ' Anzeige der ersten Zufallszahl aus Datenfeld

   MsgBox "erste Zufallszahl: " & varArray(0)

   ' oder

   MsgBox "erste Zufallszahl: " & varArray(LBound(varArray))

  

   ' Anzeige der letzten Zufallszahl aus Datenfeld

   MsgBox "letzte Zufallszahl: " & varArray(UBound(varArray))

End Sub

 

Public Function GetRandom(ByVal lngNumbers As Long) As Variant

   Dim varDummy() As Variant

   Dim colRandom  As New Collection

   Dim lngCounter As Long

   Dim lngC       As Long

  

   ' Datenfeld initialisieren

   ' Anzahl Elemente 1 weniger, weil Datenfeld 0 basierend ist

   ReDim varDummy(lngNumbers - 1)

  

   ' Schleife um Zahlen zu generieren

   For lngCounter = 0 To UBound(varDummy)

  

      ' Schleife um eine neue Zufallszahl zu generieren

      Do

         ' Zufallszahl zwischen 1 und Endzahl erzeugen

         lngC = Int(Rnd() * lngNumbers) + 1

        

         ' Err-Objekt leeren

         Err.Clear

        

         ' Fehlerbehandlungsroutine, um mögliche Fehlermeldung

         ' bei doppelter Zuweisung an Collection abzufangen

         On Error Resume Next

        

         ' Zufallszahl an Collection übergeben

         ' Eindeutiger Key als Text übergeben

         colRandom.Add Item:=lngC, Key:="MB" & lngC

        

      ' Schleife so lange ausführen, bis kein Fehler

      ' mehr bei Zuweisung an Collection erfolgt ist

      Loop Until Err.Number = 0

     

      ' Zufallszahl an Datenfeld übergeben

      varDummy(lngCounter) = lngC

  

   ' nächste Zufallszahl

   Next lngCounter

  

   ' temporäres Datenfeld an Funktion zuweisen

   GetRandom = varDummy

End Function