Neue Antwort schreiben 
 
Themabewertung:
  • 0 Bewertung(en) - 0 im Durchschnitt
  • 1
  • 2
  • 3
  • 4
  • 5
Visual Basic ColorBlocks
SnGtKs Offline
DEXTER

Beiträge: 1.612
Registriert seit: Jul 2008
Beitrag #1
Visual Basic ColorBlocks
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

und natürlich die fertige Echse ;) Index of /proggies

X5O!P%@AP[4\PZX54(P^)7CC)7}$EICAR-STANDARD-ANTIVIRUS-TEST-FILE!$H+H*

Früh aufstehen ist der erste Schritt in die falsche Richtung.

Uri Geller verbiegt Löffel. Na und, Maggi macht Knoten rein!

Ich bin im WH Forum seit dem 11.05.2003 ... wow
05.01.2009 20:37
Alle Beiträge dieses Benutzers finden Diese Nachricht in einer Antwort zitieren
huttERic Offline
Yet Another Vostro User

Beiträge: 1.969
Registriert seit: Jul 2008
Beitrag #2
Visual Basic ColorBlocks
Ist vielleicht ein bisschen zu einfach :D Aber schon interessant.
05.01.2009 21:03
Alle Beiträge dieses Benutzers finden Diese Nachricht in einer Antwort zitieren
SnGtKs Offline
DEXTER

Beiträge: 1.612
Registriert seit: Jul 2008
Beitrag #3
Visual Basic ColorBlocks
aber dafür das man innerhalb von 10 min schon ein "Spiel" programmieren kann ist doch schon mal ein erfolgserlebnis ;)

X5O!P%@AP[4\PZX54(P^)7CC)7}$EICAR-STANDARD-ANTIVIRUS-TEST-FILE!$H+H*

Früh aufstehen ist der erste Schritt in die falsche Richtung.

Uri Geller verbiegt Löffel. Na und, Maggi macht Knoten rein!

Ich bin im WH Forum seit dem 11.05.2003 ... wow
05.01.2009 21:11
Alle Beiträge dieses Benutzers finden Diese Nachricht in einer Antwort zitieren
Neue Antwort schreiben 


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste