FloodIt in Excel – Ein farbenfrohes Spiel mit VBA bauen (Schritt-für-Schritt, auch für Einsteiger)

 Option Explicit
Public Const VERTICAL_GRID As Integer = 16
Public Const HORIZONTAL_GRID As Integer = 16
Public Const PLAYFIELDS As Integer = 6
Public counter As Integer

Function rand(PLAYFIELDS)
Dim Obergrenze As Integer
Dim Untergrenze As Integer
Obergrenze = PLAYFIELDS
+ 3 Untergr
nze = 3 rand = Int((Obergrenze - Untergrenze + 1) * Rnd +
End Function

Function grow(old_value, new_value, v_position, h_position)
' Grenzen prüfen BEVOR wir etwas ändern
If v_position < 3 Or v_position > VERTICAL_GRID + 2 Then Exit Function
If h_position < 1 Or h_position > HORIZONTAL_GRID Then Exit Function
' Nur ändern wenn aktuelles Feld die alte Farbe hat
If Cells(v_position, h_position).Value <> old_value Then Exit Function

' Farbe ändern
Cells(v_position, h_position).Value = new_value
Cells(v_position, h_position).Interior.ColorIndex = new_value

' Rekursiv zu benachbarten Feldern
If h_position + 1 <= HORIZONTAL_GRID Then
    If Cells(v_position, h_position + 1).Value = old_value Then
        Call grow(old_value, new_value, v_position, h_position + 1)
    End If
End If

If v_position + 1 <= VERTICAL_GRID + 2 Then
    If Cells(v_position + 1, h_position).Value = old_value Then
        Call grow(old_value, new_value, v_position + 1, h_position)
    End If
End If

If h_position - 1 >= 1 Then
    If Cells(v_position, h_position - 1).Value = old_value Then
        Call grow(old_value, new_value, v_position, h_position - 1)
    End If
End If

If v_position - 1 >= 3 Then
    If Cells(v_position - 1, h_position).Value = old_value Then
        Call grow(old_value, new_value, v_position - 1, h_position)
    End If
End If
End Function

Sub pixel_it_start()
ApplicaFalse
Application.EnableEvenFalse
Application.ScreenUpdatiFalse
Cells.MergeCelFalse
Dim pf As Integer, v As Integer, h As Integer
Dim this_value As Integer

Cells.Clear
counter = 0

Cells(1, 1) = "Pixel It - Klick hier für Neustart"
Cells(1, 1).Font.Bold = True
Cells(1, 1).Interior.Color = RGB(200, 200, 200)

Cells(1, HORIZONTAL_GRID).Value = "Züge: 0"
Cells(1, HORIZONTAL_GRID).Font.Bold = True

Cells(2, 1).Value = ""
Cells(2, 1).Font.Color = RGB(255, 255, 255)

Randomize
For v = 1 To VERTICAL_GRID
    For h = 1 To HORIZONTAL_GRID
        this_value = rand(PLAYFIELDS)
        Cells(2 + v, h) = this_value
        Cells(2 + v, h).ColumnWidth = 3
        Cells(2 + v, h).RowHeight = 15
        Cells(2 + v, h).Interior.ColorIndex = this_value
    Next h
Next v

Cells(20, 1) = "Klicke auf eine Farbe:"
Cells(20, 1).Font.Bold = True

For pf = 3 To PLAYFIELDS + 3
    Cells(21, pf - 2).Interior.ColorIndex = pf
    Cells(21, pf - 2).Value = pf
    Cells(21, pf - 2).ColumnWidth = 4
    Cells(21, pf - 2).RowHeight = 20
    Cells(21, pf - 2).HorizontalAlignment = xlCenter
    Cells(21, pf - 2).Font.Bold = True
Next pf

Cells(23, 1) = "Status: Spiel läuft..."
Cells(23, 1).Font.Bold = True
Cells(23, 1).Interior.Color = RGB(240, 240, 240)

Application.ScreenUpdating = True
Application.ScreenUpdating = True
Application.EnableEvents = True

Cells(3, 1).Select
MsgBox "Willkommen zu (Un-)PixelIt!" & Chr(13) & Chr(10) & _
       "Klicke auf die Farbfelder in Zeile 21, um das Spiel zu spielen!" & Chr(13) & Chr(10) & _
       "Ziel: Alle Felder in derselben Farbe!", vbInformation, "PixelIt"
End Sub

Sub pixel_it_change()
Dim old_value As Integer
Dim new_value As Integer
old_value = Cells(3, 1).Value
new_value = Cells(2, 1).Value

' Debug-Ausgabe
Debug.Print "Old Value: " & old_value & ", New Value: " & new_value

If old_value <> new_value And new_value >= 3 And new_value <= PLAYFIELDS + 3 Then
    counter = counter + 1
    Cells(1, HORIZONTAL_GRID).Value = "Züge: " & counter
    
    Application.ScreenUpdating = False
    Call grow(old_value, new_value, 3, 1)
    Application.ScreenUpdating = True
    
    ' Gewinn-Check
    Call check_win
End If

Cells(2, 1).Value = ""
Cells(3, 1).Select
End Sub

Sub check_win()
Dim firstColor As Integer
Dim allSame As Boolean
Dim v As Integer, h As Integer
Dim winRange As Range
Set winRange = Range(Cells(VERTICAL_GRID + 7, 1), Cells(VERTICAL_GRID + 7, 4))
firstColor = Cells(3, 1).Value
allSame = True

' Alle Spielfelder prüfen
For v = 1 To VERTICAL_GRID
    For h = 1 To HORIZONTAL_GRID
        If Cells(2 + v, h).Value <> firstColor Then
            allSame = False
            Exit For
        End If
    Next h
    If Not allSame Then Exit For
Next v

If allSame Then
    With winRange
        .Merge
        .Value = "GEWONNEN! Klick hier für Neustart"
        .Interior.Color = RGB(144, 238, 144)
        .Font.Bold = True
        .WrapText = True
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .RowHeight = 28
    End With
    
    MsgBox "Glückwunsch! Du hast gewonnen!" & Chr(13) & Chr(10) & _
           "Züge benötigt: " & counter & Chr(13) & Chr(10) & _
           "Klicke auf das hellgrüne 'Gewonnen'-Feld für ein neues Spiel!", vbInformation, "Gewonnen!"
End If
End Sub

 Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = "$A$1" Then Call pixel_it_start Exit Sub End If' Gewonnen-Feld (gemergter Bereich) für Neustart
Dim ws As Worksheet
Dim winRange As Range
Dim txt As String

Set ws = Me
Set winRange = ws.Range(ws.Cells(VERTICAL_GRID + 7, 1), ws.Cells(VERTICAL_GRID + 7, 4))

If Not Intersect(Target, winRange) Is Nothing Then
    ' Text sicher auslesen
    On Error Resume Next
    If winRange.MergeCells Then
        txt = CStr(winRange.Cells(1, 1).Value)
    Else
        txt = CStr(winRange.Cells(1, 1).Value)
    End If
    On Error GoTo 0

    If Len(txt) > 0 And InStr(1, txt, "GEWONNEN", vbTextCompare) > 0 Then
        Application.EnableEvents = False
        pixel_it_start
        Application.EnableEvents = True
    End If
    Exit Sub
End If

' Farbauswahl durch Klick auf Farbfelder (ZEILE 21!)
If Target.Row = 21 And Target.Column >= 1 And Target.Column <= PLAYFIELDS + 1 Then
    Dim old_value As Integer
    Dim new_value As Integer

    old_value = Me.Cells(3, 1).Value
    new_value = Target.Value

    If old_value <> new_value Then
        counter = counter + 1
        Me.Cells(1, HORIZONTAL_GRID).Value = "Züge: " & counter

        Application.ScreenUpdating = False
        grow old_value, new_value, 3, 1
        Application.ScreenUpdating = True

        check_win
    End If
End If
End Sub