Colo's Excel Junk Room

Excel Snake

Thanks a lot for visiting the "Excel Snake" site. You need Excel 97 or a later version to play this game.

How to play is quite simple. You can use either two arrow keys (left and right) or four arrow keys (left, right, up and down).

The object of the game is to eat all of the apples for each stage.

When you've eaten enough apples, an exit will appear. You can use the exit to go to the next stage.

Good luck!

update! 5th Aug. 2004: Keys option has been added.

Download

Excel Snake

Source Code

Here is the source code of this game.

Option Explicit
Option Base 1

'API function
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Integer) As Long

'Constants
Const VK_LEFT As Long = &H25
Const VK_RIGHT As Long = &H27
Const VK_CONTROL As Long = &H11

'Variables
Dim lTime As Long    'a timer coefficient for sleep API
Dim lTmpg As Long    'a timer coefficient
Dim lLength As Long  'the length of the Excel Snake
Dim lGrow As Long    '  'the length of the Excel Snake's growth

Dim r() As Long    'the Row of the Excel Snake
Dim c() As Long    'the Column of the Excel Snake
Dim lDrc As Long    'the direction of the Excel Snake

Dim bStart As Boolean    'for setting direction of the Excel Snake
Dim bAbort As Boolean    'for judging abort
Dim bApple As Boolean    'for adding an apple
Dim bSecondStage As Boolean    'for judging if stage is cleared

Dim lColorEs As Long    'The color of the Excel Snake
Dim lColorBg As Long    'The color of the Back Ground
Dim lColorWl As Long    'The color of the Wall
Dim lColorMl As Long    'The color of the apples

Private Sub Auto_Open()
    ActiveCell.Activate    'for Excel97
    wks_main.Unprotect
    Application.OnKey "~", "StartGame"
    Cells.Interior.ColorIndex = xlNone
    wks_main.Shapes("title").Visible = True
    wks_main.Shapes("apple").Visible = False
    bSecondStage = False
    wks_main.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub

Private Sub Auto_Close()
Application.OnKey "~"
End Sub

Private Sub StartGame()
    ActiveCell.Activate    'for Excel97
    wks_main.Unprotect
    SettingGame
    MainLoop
End Sub

Private Sub SettingGame()
    If bSecondStage Then
        Range("Apples") = 10
    Else
        Range("stage") = 1
        Range("Apples") = 10
        Range("score") = 0
        Range("snakes") = 5
    End If
    CommnSetting Range("stage").Value
End Sub

Private Sub CommnSetting(lStage)
    Dim i As Long

    With wks_main
        'Setting shapes
        .Shapes("title").Visible = False
        .Shapes("apple").Visible = True

        'Setting game level
        If .Opt_Level1 Then lTime = 110: lLength = 5: lGrow = 3: lTmpg = 5
        If .Opt_Level2 Then lTime = 90: lLength = 10: lGrow = 5: lTmpg = 4
        If .Opt_Level3 Then lTime = 70: lLength = 15: lGrow = 7: lTmpg = 3
    End With

    bStart = False
    bAbort = False
    bApple = False
    Range("time").Clear

    Erase r: Erase c
    ReDim r(lLength): ReDim c(lLength)

    For i = LBound(r) To UBound(r)
        r(i) = Range("start").Row: c(i) = Range("start").Column
    Next

    Application.ScreenUpdating = False
    ChangeStage lStage
    Range("IV1").Select
    Application.Goto Range("stage00").Range("A1"), True
    Application.ScreenUpdating = True

    lColorBg = Range("stage00").Cells(2, 2).Interior.ColorIndex
    lColorWl = Range("stage00").Cells(1, 1).Interior.ColorIndex
    lColorEs = Range("EsColor").Interior.ColorIndex
    lColorMl = Range("lColorMl").Interior.ColorIndex
End Sub

Private Sub ChangeStage(ByVal lStage As Long)
ActiveCell.Activate 'for Excel97
Range("stage" & Format(lStage, "00")).Copy Range("stage00").Item(1)
End Sub

Private Sub KeyEvents()
    Sleep lTime
    If GetAsyncKeyState(VK_LEFT) <> 0 Then ChangeDirection VK_LEFT
    If GetAsyncKeyState(VK_RIGHT) <> 0 Then ChangeDirection VK_RIGHT
    If GetAsyncKeyState(VK_CONTROL) <> 0 Then bAbort = True
End Sub

Private Sub MainLoop()
    Dim i As Long
    Dim l As Long
    Dim u As Long
    Dim lTimer As Long

    AddAnApple

    With wks_main
        Do
            If bAbort Then bAbort = False: Auto_Open: End

            'Close the entrance door
            If Range("start").Interior.ColorIndex = lColorBg Then
                If Range("start").Offset(-1).Interior.ColorIndex = lColorBg Then
                    Range("stage00").Item(1).Copy Range("start")
                End If
            End If

            l = LBound(r): u = UBound(r)

            'Judgement goal
            If r(u) = 1 And c(u) = 21 Then
                If Range("goal").Interior.ColorIndex = lColorWl Then CrashEvent
                For i = LBound(r) To u
                    Range("goal").Interior.ColorIndex = lColorEs
                    .Cells(r(i), c(i)).Interior.ColorIndex = lColorBg
                    Sleep 30
                Next
                Range("goal").Interior.ColorIndex = lColorBg
                If Range("stage") = 16 Then
                    MsgBox "Yea! you did it! Please email me 'colo@puremis.net' !"
                    End
                End If

                Range("stage") = Range("stage") + 1
                Range("score") = Range("score") + 10
                bSecondStage = True
                SettingGame
                MsgBox "Are you ready!?       ", vbQuestion, "Excel Snake"
                MainLoop
            End If

            'Judgement crash
            If r(u) <> r(u - 1) Or c(u) <> c(u - 1) Then
                If .Cells(r(u), c(u)).Interior.ColorIndex = lColorWl Then CrashEvent
                For i = l To u - 1
                    If r(u) = r(i) Then
                        If c(u) = c(i) Then CrashEvent
                    End If
                Next
            End If

            'Judgement eat an apple
            If .Cells(r(u), c(u)).Interior.ColorIndex = lColorMl Then
                .Cells(r(u), c(u)).Interior.ColorIndex = lColorEs
                lLength = lLength + lGrow
                AddElement2
                Range("time").Clear
                Range("Apples") = Range("Apples") - 1
                Range("score") = Range("score") + 1
                If Range("Apples") < 1 Then
                    Range("goal").Interior.ColorIndex = lColorBg
                Else
                    If Not bApple Then AddAnApple
                    bApple = False
                End If
            End If

            'Color to Excel Snake
            .Cells(r(l), c(l)).Interior.ColorIndex = lColorBg
            .Cells(r(u), c(u)).Interior.ColorIndex = lColorEs

            'Decrease the array of Excel Snake
            DecreaseElement

            'Get key events
            KeyEvents

            'Makes the Excel Snake move
            AddElement1

            'Timer
            lTimer = lTimer + 1
            If lTimer Mod lTmpg = 0 Then lTimer = 0: TimeProgress
        Loop
    End With
End Sub

Private Sub ChangeDirection(VK As Long)
    If VK = VK_LEFT Then
        If lDrc = 4 Then
            lDrc = 1
        Else
            lDrc = lDrc + 1
        End If
    Else
        If lDrc = 1 Then
            lDrc = 4
        Else
            lDrc = lDrc - 1
        End If
    End If
End Sub

Private Sub AddElement1()
    Dim u As Long
    u = UBound(r)
    ReDim Preserve r(1 To u + 1)
    ReDim Preserve c(1 To u + 1)
    If Not bStart Then lDrc = 1: bStart = True
    u = UBound(r)
    Select Case lDrc
    Case 1: r(u) = r(u - 1) - 1: c(u) = c(u - 1)
    Case 2: r(u) = r(u - 1): c(u) = c(u - 1) - 1
    Case 3: r(u) = r(u - 1) + 1: c(u) = c(u - 1)
    Case 4: r(u) = r(u - 1): c(u) = c(u - 1) + 1
    End Select
End Sub

Private Sub AddElement2()
    Dim i As Long
    ReDim Preserve r(1 To lLength)
    ReDim Preserve c(1 To lLength)
    For i = UBound(r) To LBound(r) Step -1
        If i > lGrow Then
            r(i) = r(i - lGrow)
            c(i) = c(i - lGrow)
        Else
            r(i) = r(LBound(r))
            c(i) = c(LBound(r))
        End If
    Next
End Sub

Private Sub DecreaseElement()
    Dim t1() As Long
    Dim t2() As Long
    Dim i As Long
    ReDim t1(LBound(r) To UBound(r) - 1)
    ReDim t2(LBound(r) To UBound(r) - 1)
    For i = LBound(r) To UBound(r) - 1
        t1(i) = r(i + 1): t2(i) = c(i + 1)
    Next
    ReDim r(1 To UBound(t1))
    ReDim c(1 To UBound(t1))
    For i = LBound(t1) To UBound(t1)
        r(i) = t1(i): c(i) = t2(i)
    Next
    Erase t1: Erase t2
End Sub

Private Sub AddAnApple()
    Dim x As Long
    Dim y As Long
    Dim z As Long
    Do
        Randomize    ' Initialize random-number generator
        x = Int((40 * Rnd) + 2)
        y = Int((40 * Rnd) + 2)
        z = wks_main.Cells(x, y).Interior.ColorIndex
        If z <> lColorWl And z <> lColorEs And z <> lColorMl Then
            wks_main.Cells(x, y).Interior.ColorIndex = lColorMl
            Exit Do
        End If
    Loop
End Sub

Private Sub TimeProgress()
    Dim rTime As Range
    Dim bFlg As Boolean
    For Each rTime In Range("time")
        If rTime.Interior.ColorIndex = xlNone Then
            With rTime.Interior
                .ColorIndex = Range("lColortm").Interior.ColorIndex
                .Pattern = Range("lColortm").Interior.Pattern
                .PatternColorIndex = Range("lColortm").Interior.PatternColorIndex
            End With
            bFlg = True
            Exit For
        End If
    Next
    If Not bFlg Then
        AddAnApple
        Range("Apples") = Range("Apples") + 1
        Range("time").Clear
        bFlg = False
        bApple = True
        TimeProgress
    End If
End Sub

Private Sub CrashEvent()
    Dim x As Long
    Dim y As Long
    Dim i As Long

    On Error Resume Next
    For i = 1 To 1400
        x = Int((40 * Rnd) + 2)
        y = Int((40 * Rnd) + 2)
        Cells(x, y).Interior.ColorIndex = x
        If GetAsyncKeyState(VK_CONTROL) <> 0 Then bAbort = True
        If bAbort Then bAbort = False: Auto_Open: End
    Next
    Range("snakes") = Range("snakes") - 1

    If Range("snakes") < 0 Then
        bSecondStage = False
        MsgBox "Game Over"
        bAbort = False: Auto_Open: End
    Else
        bSecondStage = True
        MsgBox "Are you ready!?       ", vbQuestion, "Excel Snake"
        StartGame
    End If
End Sub