hier falls es jemand bracht ... nach einer idee vom Galileo Openbook
Code:
Public Class Form1
' Index des aktuellen Blocks
Dim B As Integer
' Gesamtes Spielfeld inkl. Randfelder
Dim F(14, 9) As Integer
' Zeile und Spalte des aktuellen Blocks
Dim BZe As Integer
Dim BSp As Integer
' Schwierigkeitsstufe
Dim Stufe As Integer
' Eine zunächst leere Liste von Spiel-Blöcken
Dim Block As New List(Of Panel)
' Ein Feld von Farben für die Blöcke
Dim FarbenFeld() As Color = {Color.Red, _
Color.Yellow, Color.Green, Color.Blue, _
Color.Cyan, Color.Magenta, Color.Black, _
Color.White}
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Dim Ze, Sp As Integer
' Zufallsgenerator initialisieren
Randomize()
' Feld besetzen
For Ze = 1 To 13
F(Ze, 0) = -2
For Sp = 1 To 8
F(Ze, Sp) = -1
Next Sp
F(Ze, 9) = -2
Next Ze
For Sp = 0 To 9
F(14, Sp) = -2
Next Sp
' Initialisierung
Stufe = 1
NächsterBlock()
End Sub
Private Sub NächsterBlock()
Dim Farbe As Integer
' Neuen Block zum Formular hinzufügen
Block.Add(New Panel)
' Nummer des aktuellen Blocks ermitteln
B = Block.Count - 1
' Neuen Block platzieren
Block(B).Location = New Point(100, 80)
Block(B).Size = New Point(20, 20)
' Farbauswahl für neuen Block
Farbe = Math.Floor(Rnd() * 8)
Block(B).BackColor = FarbenFeld(Farbe)
' Zum Formular hinzufügen
Controls.Add(Block(B))
' Aktuelle Zeile, Spalte
BZe = 1
BSp = 5
End Sub
Private Sub TimT_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles timT.Tick
' Falls es nicht mehr weiter geht
If F(BZe + 1, BSp) <> -1 Then
' Oberste Zeile erreicht
If BZe = 1 Then
timT.Enabled = False
MsgBox("Das war's")
Exit Sub
End If
F(BZe, BSp) = B ' Belegen
ReihePrüfen()
NächsterBlock()
Else
' Falls es noch weiter geht
Block(B).Top = Block(B).Top + 20
BZe = BZe + 1
End If
End Sub
Private Sub ReihePrüfen()
Dim Ze, Sp, ZeX, SpX As Integer
Dim Neben, Über As Boolean
Neben = False
Über = False
' Drei gleiche Steine nebeneinander?
For Ze = 13 To 1 Step -1
For Sp = 1 To 6
' Falls drei Felder nebeneinander besetzt
If F(Ze, Sp) <> -1 And F(Ze, Sp + 1) <> -1 _
And F(Ze, Sp + 2) <> -1 Then
' Falls drei Farben gleich
If Block(F(Ze, Sp)).BackColor = _
Block(F(Ze, Sp + 1)).BackColor _
And Block(F(Ze, Sp)).BackColor = _
Block(F(Ze, Sp + 2)).BackColor Then
For SpX = Sp To Sp + 2
' Block aus dem Formular löschen
Controls.Remove(Block(F(Ze, SpX)))
' Feld leeren
F(Ze, SpX) = -1
' Blöcke oberhalb des entladenen
' Blockes absenken
ZeX = Ze - 1
Do While F(ZeX, SpX) <> -1
Block(F(ZeX, SpX)).Top = _
Block(F(ZeX, SpX)).Top + 20
' Feld neu besetzen
F(ZeX + 1, SpX) = F(ZeX, SpX)
F(ZeX, SpX) = -1
ZeX = ZeX - 1
Loop
Next SpX
Neben = True
End If
End If
If Neben Then Exit For
Next Sp
If Neben Then Exit For
Next Ze
' Drei gleiche Steine übereinander?
For Ze = 13 To 3 Step -1
For Sp = 1 To 8
' Falls drei Felder übereinander besetzt
If F(Ze, Sp) <> -1 And F(Ze - 1, Sp) <> -1 _
And F(Ze - 2, Sp) <> -1 Then
' Falls drei Farben gleich
If Block(F(Ze, Sp)).BackColor = _
Block(F(Ze - 1, Sp)).BackColor _
And Block(F(Ze, Sp)).BackColor = _
Block(F(Ze - 2, Sp)).BackColor Then
' 3 Blöcke entladen
For ZeX = Ze To Ze - 2 Step -1
' Block aus dem Formular löschen
Controls.Remove(Block(F(ZeX, Sp)))
' Feld leeren
F(ZeX, Sp) = -1
Next ZeX
Über = True
End If
End If
If Über Then Exit For
Next Sp
If Über Then Exit For
Next Ze
If Neben Or Über Then
' Schneller
Stufe = Stufe + 1
timT.Interval = 5000 / (Stufe + 9)
' Eventuell kann jetzt noch eine Reihe
' entfernt werden
ReihePrüfen()
End If
End Sub
Private Sub cmdLinks_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdLinks.Click
If F(BZe, BSp - 1) = -1 Then
Block(B).Left = Block(B).Left - 20
BSp = BSp - 1
End If
End Sub
Private Sub cmdRechts_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdRechts.Click
If F(BZe, BSp + 1) = -1 Then
Block(B).Left = Block(B).Left + 20
BSp = BSp + 1
End If
End Sub
Private Sub cmdUnten_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdUnten.Click
Do While F(BZe + 1, BSp) = -1
Block(B).Top = Block(B).Top + 20
BZe = BZe + 1
Loop
F(BZe, BSp) = B 'Belegen
ReihePrüfen()
NächsterBlock()
End Sub
Private Sub cmdPause_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdPause.Click
timT.Enabled = Not timT.Enabled
End Sub
Private Sub cmdEnde_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdEnde.Click
' Beenden mit Rückfrage
If MsgBox("Wollen Sie das Programm wirklich " _
& "beenden?", MsgBoxStyle.YesNo, _
"ColorBlocks") = MsgBoxResult.Yes Then
Me.Close()
End If
End Sub
Private Sub cmdInfo_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdInfo.Click
' Beenden mit Rückfrage
MsgBox("Stapeln Sie 3 frabige Blöckr übereinander." & vbCrLf _
& "Taste A bewegt den Block nach links, " & vbCrLf _
& "Taste D bewegt den Block nach rechts, " & vbCrLf _
& "Taste S bewegt den Block nach unten, " & vbCrLf _
& "Taste P ... Pause ;), " & vbCrLf _
& "Taste E ... Programmende mit Abfrage," & vbCrLf _
& "Taste I ... Dieses nervige Info Fenster," & vbCrLf _
& "Programm ist noch Buggy ;)" & vbCrLf _
& "MfG Quasi" & vbCrLf _
& "Programm entstand in einer Nachmittags - langeweile", , "ColorBlocks")
End Sub
End Class
Aber schon interessant.