Mastermind in Visual Basic 3.0

Color Madness

Klaus Peterka

Das Programm besteht aus den 3 Formularen ABOUT.FRM, GAME.FRM und TIMEINFO.FRM. Für den Ablauf enstscheidend ist das Formular GAME.FRM. Um Platz zu sparen, wurde auf den Nachdruck der Eingeschaftenlisten der einzelnen Objekte in einem Formular verzichtet und nur der Programmkode wiedergegeben.

Programm als ZIP-Archiv

‘GAME.FRM

Dim vorgabe(0 To 4)'Zu Erratende Kombination
Dim vorgabe1(0 To 4)
Dim sstift(0 To 4)'Setzstift 4:Position 0-4
Dim lstift(0 To 4)'Lösungsstift ----"----
Dim player As String
Dim position As Integer
Dim runde As Integer
Dim yposi As Integer
Dim i As Integer
Dim z As Integer
Dim b As Integer
Dim min As Integer
Dim sek As Integer
Dim percent As Integer
Dim games As Integer
Const Meldung = "Game Over!"
Const Meldung2 = "Victory!!"
Const Titel = "CoLoR mAdNeSs"

Sub auswertung ()

Erase lstift
z = 0
vorgabe1(0) = vorgabe(0)
vorgabe1(1) = vorgabe(1)
vorgabe1(2) = vorgabe(2)
vorgabe1(3) = vorgabe(3)
vorgabe1(4) = vorgabe(4)
For i = 0 To 4
Select Case sstift(i)
Case vorgabe1(i)
lstift(z) = 2
vorgabe1(i) = 15
sstift(i) = 20
percent = percent + 20
z = z + 1
End Select
Next i
For i = 0 To 4
Select Case sstift(i)
Case vorgabe1(0)
lstift(z) = 1
vorgabe1(0) = 15
sstift(i) = 20
percent = percent + 10
z = z + 1
Case vorgabe1(1)
lstift(z) = 1
vorgabe1(1) = 15
sstift(i) = 20
percent = percent + 10
z = z + 1
Case vorgabe1(2)
lstift(z) = 1
vorgabe1(2) = 15
sstift(i) = 20
percent = percent + 10
z = z + 1
Case vorgabe1(2)
lstift(z) = 1
vorgabe1(2) = 15
sstift(i) = 20
percent = percent + 10
z = z + 1
Case vorgabe1(3)
lstift(z) = 1
vorgabe1(3) = 15
sstift(i) = 20
percent = percent + 10
z = z + 1
Case vorgabe1(4)
lstift(z) = 1
vorgabe1(4) = 15
sstift(i) = 20
percent = percent + 10
z = z + 1
End Select
Next i
For i = 0 To 4
Select Case lstift(i)
Case 0
fillcolor = &H808080 '=Hintergrundfarbe
Case 1
fillcolor = RGB(255, 255, 255)
Case 2
fillcolor = RGB(0, 0, 0)
End Select
Circle (340 + 20 * i, _
50 * yposi + 50), 5
Next i
Gauge1.Value = percent
percent = 0
If lstift(0) = 2 And lstift(1) = 2 And _
lstift(2) = 2 And lstift(3) = 2 And _
lstift(4) = 2 Then
'Spiel gewonnen!
MsgBox Meldung2, 48, Titel
Cls
Call program_end
Call Show_Solution
End If
If runde = 21 Then
Call game_over
End If
If runde = 7 Or runde = 14 Then
'7 Reihen fertig bestückt
yposi = 0
End If
End Sub

Sub Blau_Click ()

position = position + 1
Call roundfinished
fillcolor = RGB(0, 0, 255)
Circle (50 * position + 50, _
50 * yposi + 50), 15
sstift(position) = 4
If position = 4 Then
Call auswertung
End If
Call clearall
End Sub

Sub clearall ()

If position = 0 Then
For i = 1 To 4
fillcolor = &H808080
Circle (50 * i + 50, _
50 * yposi + 50), _
15, &H808080
Next i
For i = 0 To 4
Circle (340 + 20 * i, _
50 * yposi + 50), 5
Next i
End If
End Sub

Sub Form_Load ()

b = 0
games = 0
ScaleMode = 3
FillStyle = 0
Weiß.Enabled = False
Schwarz.Enabled = False Rot.Enabled = False
Grün.Enabled = False
Blau.Enabled = False
Gelb.Enabled = False
Call nameEntry
End Sub

Sub game_over ()

timer1.Enabled = False
Weiß.Enabled = False
Schwarz.Enabled = False
Rot.Enabled = False
Grün.Enabled = False
Blau.Enabled = False
Gelb.Enabled = False
'Game Over anzeigen
MsgBox Meldung, 48, Titel
Cls
Start.Visible = True
Call Show_Solution
End Sub

Sub Gelb_Click ()

position = position + 1
Call roundfinished
fillcolor = RGB(255, 255, 0)
Circle (50 * position + 50, _
50 * yposi + 50), 15
sstift(position) = 5
If position = 4 Then
Call auswertung
End If
Call clearall
End Sub

Sub Grün_Click ()

position = position + 1
Call roundfinished
fillcolor = RGB(0, 255, 0)
Circle (50 * position + 50,
50 * yposi + 50), 15
sstift(position) = 3
If position = 4 Then
Call auswertung
End If
Call clearall
End Sub

Sub menuInformationAbout_Click _

(Index As Integer)
About.Show
End Sub

Sub menuInformationTime_Click _

(Index As Integer)
TimeInfo.Show
End Sub

Sub menuNew_click (Index As Integer)

Call newgame
End Sub

Sub menuOptionsAutoRedraw_Click ()

If b = 1 Then
game.AutoRedraw = False
b = 0
menuOptionsAutoRedraw.Checked = False
MsgBox "Auto Redraw Disabled", 64, _
"AutoRedraw"
Else
game.AutoRedraw = True
b = 1
menuOptionsAutoRedraw.Checked = True
MsgBox "Auto Redraw Enabled", 64, _
"AutoRedraw"
End If
End Sub

Sub menuOptionsName_Click ()

Call nameEntry
End Sub

Sub menuPictureLoad_Click _

(Index As Integer)
CMDialog1.InitDir = "C:\"
CMDialog1.DefaultExt = "BMP"
CMDialog1.Filter = _
"BMP-Pictures (*.BMP)|*.BMP|"
CMDialog1.Action = 1
game.Picture = _ LoadPicture(CMDialog1.Filename)
End Sub

Sub menuQuit_Click (Index As Integer)

End
End Sub

Sub menuSolutionShow_Click _

(Index As Integer)
Call Show_Solution
End Sub

Sub nameEntry ()

player = _
InputBox("Please enter your Name:", _
"CoLoR mAdNeSs", "Nobody")
Label12.Caption = player
game.Caption = _
"ColoR mAdNeSs - " & player
End Sub

Sub newgame ()

sek = 0
min = 0
percent = 0
games = games + 1
position = -1
runde = 1
yposi = 1
Erase lstift
Erase sstift
Erase vorgabe
game2.Caption = games
round.Caption = runde
Cls
'Lösung durch Zufallsgenerator
Randomize
For i = 0 To 4
vorgabe(i) = Int(6 * (Rnd(5)))
Next i
Start.Visible = False
fillcolor = &H808080
For y = 1 To 7
For i = 0 To 4
Circle (340 + 20 * i, _
50 * y + 50), 5
Next i
Next y
Weiß.Enabled = True
Schwarz.Enabled = True
Rot.Enabled = True
Grün.Enabled = True
Blau.Enabled = True
Gelb.Enabled = True
timer1.Enabled = True
End Sub

Sub program_end ()

timer1.Enabled = False
Start.Visible = True
Weiß.Enabled = False
Schwarz.Enabled = False
Rot.Enabled = False
Grün.Enabled = False
Blau.Enabled = False
Gelb.Enabled = False
End Sub

Sub Rot_Click ()

position = position + 1
Call roundfinished
fillcolor = RGB(255, 0, 0)
Circle (50 * position + 50, _
50 * yposi + 50), 15
sstift(position) = 2
If position = 4 Then
Call auswertung
End If
Call clearall
End Sub

Sub roundfinished ()

'=Eine Reihe fertig bestückt
If position > 4 Then
runde = runde + 1
yposi = yposi + 1
position = 0
round.Caption = runde
End If
End Sub

Sub Schwarz_Click ()

position = position + 1
Call roundfinished
fillcolor = RGB(0, 0, 0)
Circle (50 * position + 50, _
50 * yposi + 50), 15
sstift(position) = 0
If position = 4 Then
Call auswertung
End If
Call clearall
End Sub

Sub Show_Solution ()

For i = 0 To 4
Select Case vorgabe(i)
Case 0
fillcolor = RGB(0, 0, 0)
Case 1
fillcolor = RGB(255, 255, 255)
Case 2
fillcolor = RGB(255, 0, 0)
Case 3
fillcolor = RGB(0, 255, 0)
Case 4
fillcolor = RGB(0, 0, 255)
Case 5
fillcolor = RGB(255, 255, 0)
End Select
Circle (50 + 50 * i, 20), 15
Next i
End Sub

Sub Start_Click ()

Call newgame
End Sub

Sub Timer1_Timer ()

If sek = 59 Then
min = min + 1
sek = 0
Else
sek = sek + 1
End If
minbox.Caption = min
sekbox.Caption = sek
End Sub

Sub Undo_Click ()

If position < 0 Or position = 4 Then
Else
position = position - 1
fillcolor = &H808080
Circle (50 * position + 100, _
50 * yposi + 50), 15 'zeichnet Stift
End If
End Sub

Sub Weiß_Click ()

position = position + 1
Call roundfinished
fillcolor = RGB(255, 255, 255)
'Spielfarbe
Circle (50 * position + 50, _
50 * yposi + 50), 15 'zeichnet Stift
sstift(position) = 1
If position = 4 Then
Call auswertung
End If
Call clearall
End Sub