Programme: Mastermind

Form                     frmMastermind
Line                     Line1
PictureBox               picPin
PictureBox               picPin
PictureBox               picPin
PictureBox               picPin
Shape                    BingoBox
Shape                    BingoBox
Shape                    BingoBox

' VISUAL BASIC WORLD
' ===========================================
' Das große Portal zum Thema Visual Basic.
'
' Wenn Ihnen dieser Source Code gefallen hat,
' dann empfehlen Sie Visual Basic World bitte
' weiter und/oder setzen Sie einen Link auf:
'
' http://www.visualbasicworld.de/
'
' Vernetzen Sie sich mit uns:
'
' http://twitter.com/visualbasicwrld
'
' Dieses Programm ist urheberrechtlich geschützt
' und darf nur für private und nicht kommerzielle
' Zwecke verwendet werden!
'
' Programm: Mastermind
' Autoren: Daniel Berger, Alexander Kopatz
' Version: 1.0
' Datum: 2011-07-31
'
 
Option Explicit
 
Private Const MaxRounds As Integer = 10 'Maximale Anzahl an Runden
Private Const MaxPins As Integer = 4 'Maximale Anzahl an Spielsteinen (Pins) pro Runde
 
Private iZähler As Integer
Private iPin As Integer
 
'--- Globaler Speicher für Farben und Ergebnisse ---'
 
Private Type typRunde
   iFarbe(1 To 4) As Integer 'Welche Farbe hat welcher Stein
   iTreffer(1 To 4) As Integer 'diese Treffer wurden erzielt
End Type
 
Private Runde() As typRunde
 
'--- Zwischenspeicher für Runde und Pin ---'
 
Private iBuffRunde As Integer
Private iBuffPin As Integer
 

 
Private Sub CreateSpielfeld()
 
   '=== Diese Funktion generiert dynamisch ein Spielfeld ==='
 
   For iZähler = 1 To MaxRounds
 
      For iPin = 1 To MaxPins
 
         '=== leere Pins für das Spielfeld laden ==='
 
         Load Me.picPin(iZähler * 10 + iPin)
            'Spielfelder werden erst zur Laufzeit dynamisch erstellt
 
         With Me.picPin(Me.picPin.UBound)
            .Top = iZähler * 750 + 350
            .Left = iPin * 825 - 600
            .Visible = True
         End With
 
         '=== leere BingoBoxen laden ==='
 
         Load Me.BingoBox(iZähler * 10 + iPin)
 
         With Me.BingoBox(Me.BingoBox.UBound)
 
            If iPin <= 2 Then
               'Bei BingoBox 1 und 2 wird ein anderer Top-Wert
               'benötigt als bei BingoBox 3 und 4
               .Top = iZähler * 750 + 400
 
            Else
               Me.BingoBox(Me.BingoBox.UBound).Top = iZähler * 750 + 675
 
            End If
 
               If iPin Mod 2 = 0 Then .Left = .Left + 250
                  'Alle geraden BingoBoxen (2 und 4) werden zusätzlich
                  'um 250 nach Rechts verschoben um ins Bild zu passen
 
            .Visible = True
 
         End With
 
      Next
 
   Next
 
   Me.Height = Me.picPin(Me.picPin.UBound).Top + 1250
 
End Sub
 

 
Private Sub GetRndFirstSet()
 
   '=== Funktion erzeugt die erste zufällige Farbenreihe ==='
 
   Randomize Timer
      'Zufallsgenerator wird mit dem Timer-Counter initialisiert um
      'nicht bei jeder Spielrunde die selben Zufallszahlen zu erhalten.
 
   ReDim Runde(1)
 
   For iPin = 1 To MaxPins
 
      Runde(0).iFarbe(iPin) = Int((Rnd * 6) + 1)
      Runde(1).iFarbe(iPin) = 7
 
   Next
 
End Sub
 

 
Private Function GetColor(ByRef iFarbe As Integer) As Long
 
   Select Case iFarbe
 
      Case 1: GetColor = RGB(&HFF, 0, 0) 'rot
      Case 2: GetColor = RGB(0, &HFF, 0) 'grün
      Case 3: GetColor = RGB(0, 0, &HFF) 'blau
      Case 4: GetColor = RGB(&HFF, &HFF, 0) 'gelb
      Case 5: GetColor = RGB(&HFF, &HAF, 0) 'orange
      Case 6: GetColor = RGB(&HAB, 0, &HFF) 'lila
      Case 7: GetColor = vbWhite
 
      Case 0: GetColor = &HE0E0E0
 
   End Select
 
End Function
 

 
Private Sub PrintSpielfeld()
 
Dim iCounter As Long
 
'--- Treffer zurücksetzen
 
   For iZähler = 0 To UBound(Runde)
      For iPin = 1 To MaxPins
         Me.BingoBox(iZähler * 10 + iPin).Tag = "0"
         Me.BingoBox(iZähler * 10 + iPin).FillColor = &HE0E0E0
      Next
   Next
 
'--- Normale Steine und Treffer zeichnen
 
   For iZähler = 0 To UBound(Runde)
 
      For iPin = 1 To MaxPins 'Normale Spielsteine (Pins) zeichnen
         Me.picPin(iZähler * 10 + iPin).BackColor = GetColor(Runde(iZähler).iFarbe(iPin))
      Next
 
   'Hier werden die Trefferfelder (BingoBoxen) gezeichnet. Um keinen Hinweis
   'auf die Position der Pins zu heben werden zunächst die Volltreffer gezeichnet
   'und erst danach die Farbtreffer.
 
         For iPin = 1 To MaxPins 'Volltreffer zeichnen
            If Runde(iZähler).iTreffer(iPin) = 1 Then
 
               For iCounter = 1 To MaxPins
 
                  With Me.BingoBox(iZähler * 10 + iCounter)
                     If .Tag = "0" Then
                        .FillColor = GetColor(1)
                        .Tag = "1"
 
                           If iCounter = 4 Then
                              Victory
                              Exit Sub
                           End If
 
                        Exit For
 
                     End If
                  End With
 
               Next
 
            End If
         Next
 
         For iPin = 1 To MaxPins 'Farbtreffer zeichnen

            If Runde(iZähler).iTreffer(iPin) = 2 Then
 
               For iCounter = 1 To MaxPins
 
                  With Me.BingoBox(iZähler * 10 + iCounter)
                     If .Tag = "0" Then
                        .FillColor = GetColor(2)
                        .Tag = "2"
 
                        Exit For
 
                     End If
                  End With
 
               Next
 
            End If
         Next
 
   Next
 
End Sub
 

 
Private Sub RundeBeenden()
 
'--- Prüfen ob alle Felder ausgefüllt wurden
 
   For iPin = 1 To MaxPins
      If Runde(UBound(Runde)).iFarbe(iPin) = 7 Then: Exit Sub
   Next
 
 
'--- Die Treffer prüfen
 
   For iZähler = 1 To MaxPins
      If Runde(0).iFarbe(iZähler) = Runde(UBound(Runde)).iFarbe(iZähler) Then
         Runde(UBound(Runde)).iTreffer(iZähler) = 1 'Volltreffer
      Else
         For iPin = 1 To MaxPins
            If Runde(UBound(Runde)).iTreffer(iPin) = 0 Then
               If Runde(0).iFarbe(iZähler) = Runde(UBound(Runde)).iFarbe(iPin) Then
                  Runde(UBound(Runde)).iTreffer(iPin) = 2: Exit For 'Farbtreffer
               End If
            End If
         Next
      End If
   Next
 
 
'--- Nächste Spielfeldrunde aktivieren
 
   If UBound(Runde) < MaxRounds Then
 
      ReDim Preserve Runde(UBound(Runde) + 1)
 
      For iPin = 1 To MaxPins
 
         Runde(UBound(Runde)).iFarbe(iPin) = 7
 
      Next
 
   Else
      For iZähler = 1 To MaxPins
         picPin(iZähler).Visible = True
      Next
 
   End If
 
End Sub
 

 
Private Sub Victory()
 
   Beep
   MsgBox "Herzlichen Glückwunsch! Sie haben diese Partie in Runde " & _
      UBound(Runde) - 1 & " gewonnen!", vbInformation, "Sieg!"
 
   For iZähler = 0 To UBound(Runde)
      For iPin = 1 To MaxPins
         Me.picPin(iZähler * 10 + iPin).Enabled = False
            'Alle Felder sperren...
      Next
   Next
 
   For iZähler = 1 To MaxPins
      picPin(iZähler).Visible = True
   Next
 
End Sub
 

 
Private Sub Form_DblClick()
 
   If Me.picPin(11).Enabled = False Then Exit Sub
      'Spiel bereits gewonnen...
 
 RundeBeenden
 PrintSpielfeld
 
End Sub
 

 
Private Sub Form_Load()
 
   'Hier geht's los! :-)
 
   CreateSpielfeld
   GetRndFirstSet
   PrintSpielfeld
 
End Sub
 


Private Sub picPin_MouseUp(Index As Integer, Button As Integer, _
   Shift As Integer, X As Single, Y As Single)
 
   iBuffRunde = Int(Index / 10) 'Ermittelt die aktuelle Runde
   iBuffPin = Index Mod 10 'Ermittelt den aktuellen Pin
 
   If iBuffRunde = UBound(Runde) Then
      'Abfrage stellt sicher, dass immer nur die gerade
      'aktive Runde bearbeitet werden kann (darf).
 
      With Runde(iBuffRunde)
 
         If Button = 1 Then
            .iFarbe(iBuffPin) = .iFarbe(iBuffPin) + 1
         Else
            .iFarbe(iBuffPin) = .iFarbe(iBuffPin) - 1
         End If
 
         If .iFarbe(iBuffPin) >= 7 Then .iFarbe(iBuffPin) = 1
         If .iFarbe(iBuffPin) <= 0 Then .iFarbe(iBuffPin) = 6
 
      End With
 
      picPin(Index).BackColor = GetColor(Runde(iBuffRunde).iFarbe(iBuffPin))
 
   End If
 
End Sub