20
\$\begingroup\$

is a game where you control a snake in an enclosed square without running into the walls or your own body. The snake grows when you run into whatever item you are supposed to run into.

My snake eats mice:

click to watch on youtube

Gameplay

You can get it to play from github and hopefully it will work

To be clear, it's fully functional- just click the "begin" button or run the "DrawGameBoard" macro to begin and use your arrow keys to navigate.


Sadly, this snake runs on Worksheet_Selection_Change event. Because I need to store values after exiting the procedure, I couldn't figure out how to implement a Class.

Some other things I should mention I struggled with -

  1. Knowing where the end of the snake is to erase it
  2. Growing the snake when it eats a mouse
  3. Timing, of course. I think I could use a library?
  4. Illegal moves - you can't turn backward
  5. The formatting - it fits my view, but that's pretty local
  6. Storing the snake's path and current location to retrieve after moving, which means there are a lot of named ranges.
  7. VBA is not meant for this

I should also note that this snake moves in fixed vectors, meaning left is always to the player's left.

I imagine there's a lot to improve upon and I don't expect anyone to tackle the whole thing.


There are several parts of the game in the same module, but I'll break them apart here for clarity.

Sheet Module

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal target As Range)
    If Intersect(target, GameSheet.Range("Board")) Is Nothing Then Exit Sub
    If Range("FirstMove").value > 0 Then
        GameSheet.Activate
        Range("FirstMove").value = 0
        Application.OnTime Now + TimeValue("00:00:02"), "Start_Timing"
        Exit Sub
    End If
    If Range("LegalMove") = 0 Then
        Range("LegalMove") = 1
        Exit Sub
    End If

    Dim storedLocation() As String
    storedLocation = Split(Range("Position"), ",")
    Dim currentLocation As Range
    Set currentLocation = Cells(CLng(storedLocation(0)), CLng(storedLocation(1)))
    Main currentLocation, target
End Sub

Constants

(and a global)

Attribute VB_Name = "Snake"
'Play the Snake Game
'Copyright 2017 Raymond Wise @ [Github Source](https://github.com/RaymondWise/Snake)

Option Explicit
    Const UP_CODE As Long = 233
    Const DOWN_CODE As Long = 234
    Const LEFT_CODE As Long = 231
    Const RIGHT_CODE As Long = 232
    Const BODY_SEGMENT As Long = 110
    Const MOUSE As Long = 56
    Const MOUSE_HIGHLIGHT As Long = 65535
    Const DELIMITER As String = ","
    Const START As String = "16,16"
    Const START_PATH As String = "$P$16"
    Const LEGAL As Long = 1
    Const ILLEGAL As Long = 0
    Const GAME_MIN_CELLS_VALUE As Long = 2
    Const GAME_MAX_CELLS_VALUE As Long = 31
    Const FREEZE_PANE_PIVOT As Long = 40
    Const GAME_ZOOM As Long = 100
    Const TIME_ITERATION_VALUE As String = "00:00:01"
    Const MAXIMUM_RIBBON_HEIGHT As Long = 70

    Public timerActive As Boolean

Create the Board

Public Sub DrawGameBoard()
    Const SNAKE_FONT As String = "Wingdings"
    Const SNAKE_FONT_BOLD As Boolean = True
    Const SNAKE_FONT_SIZE As Long = 12
    Const COLUMN_WIDTH As Double = 3
    Const ROW_HEIGHT As Double = 21.75
    Dim borders As Range
    With GameSheet
        Dim boardRange As Range
        Dim gameRange As Range
        Set boardRange = .Range("A1:AF32")
        boardRange.Name = "Board"
        Set gameRange = .Range("B2:AD31")
        gameRange.Name = "GameRange"
        With boardRange
            .Clear
            .Font.Size = SNAKE_FONT_SIZE
            .Font.Name = SNAKE_FONT
            .Font.Bold = SNAKE_FONT_BOLD
            .Columns.ColumnWidth = COLUMN_WIDTH
            .Rows.RowHeight = ROW_HEIGHT
            .Rows(1).Name = "TopBorder"
            .Rows(100).EntireRow.Hidden = True
            .Rows(32).Name = "BottomBorder"
            .Columns(1).Name = "RightBorder"
            .Columns(32).Name = "LeftBorder"
            .Cells(100, 1).Name = "Position"
            .Cells(100, 2).Name = "PathString"
            .Cells(100, 3).Name = "FirstMove"
            .Cells(100, 4).Name = "HorizontalMovement"
            .Cells(100, 5).Name = "VerticalMovement"
            .Cells(100, 6).Name = "LegalMove"
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
        End With
        .Range("TopBorder").Interior.Color = vbBlack
        .Range("BottomBorder").Interior.Color = vbBlack
        .Range("RightBorder").Interior.Color = vbBlack
        .Range("LeftBorder").Interior.Color = vbBlack
        FreezeThePanes FREEZE_PANE_PIVOT, FREEZE_PANE_PIVOT
    End With
    Set borders = Application.Union(Range("TopBorder"), Range("BottomBorder"), Range("LeftBorder"), Range("RightBorder"))
    borders.Name = "Borders"
    For Each boardRange In Range("Borders")
        boardRange.value = Chr$(BODY_SEGMENT)
    Next
    If CommandBars("Ribbon").Height > MAXIMUM_RIBBON_HEIGHT Then CommandBars.ExecuteMso ("MinimizeRibbon")
    ActiveWindow.Zoom = GAME_ZOOM
    ResetBoard
End Sub

Private Sub ResetBoard()

    With GameSheet
        .Range("FirstMove") = 1
        .Range("HorizontalMovement") = 0
        .Range("VerticalMovement") = 0
        .Range("GameRange").ClearContents
        .Range("GameRange").Interior.Color = xlNone
        .Range("Position").value = START
        .Range("PathString").value = START_PATH
        .Range("LegalMove").value = LEGAL
        .Cells(16, 16) = Chr$(BODY_SEGMENT)
        .Cells(16, 16).Select
    End With

    PlaceMouse
    Stop_Timing
End Sub
Private Sub PlaceMouse()
    Dim randRow As Long
    Dim randColumn As Long
TryAgain:
    randRow = Int((GAME_MAX_CELLS_VALUE - GAME_MIN_CELLS_VALUE + 1) * Rnd + GAME_MIN_CELLS_VALUE)
    randColumn = Int((GAME_MAX_CELLS_VALUE - GAME_MIN_CELLS_VALUE + 1) * Rnd + GAME_MIN_CELLS_VALUE)
    If IsEmpty(GameSheet.Cells(randRow, randColumn)) Then
        GameSheet.Cells(randRow, randColumn).value = Chr$(MOUSE)
        GameSheet.Cells(randRow, randColumn).Interior.Color = MOUSE_HIGHLIGHT
    Else: GoTo TryAgain
    End If
End Sub

Private Sub FreezeThePanes(ByVal fRow As Long, ByVal fColumn As Long)
    With ActiveWindow
        .SplitColumn = fColumn
        .SplitRow = fRow
        .FreezePanes = True
    End With
End Sub

Timer and Auto-movement

Public Sub Start_Timing()
    timerActive = True
    Application.OnTime Now + TimeValue(TIME_ITERATION_VALUE), "Timing"
End Sub

Public Sub Stop_Timing()
    timerActive = False
End Sub

Private Sub Timing()
    With GameSheet
        Dim repeatInterval As Date
        Dim horizontalMomentum As Long
        horizontalMomentum = Range("HorizontalMovement")
        Dim verticalMomentum As Long
        verticalMomentum = Range("VerticalMovement")
        If timerActive Then
            If horizontalMomentum = 0 Then
                MoveVertical verticalMomentum
            ElseIf verticalMomentum = 0 Then
                MoveHorizontal horizontalMomentum
            End If
        Else
            Exit Sub
        End If
        repeatInterval = Now + TimeValue(TIME_ITERATION_VALUE)
        Application.OnTime repeatInterval, "Timing"
    End With
End Sub

Private Sub MoveVertical(ByVal direction As Long)
    Dim timeTarget As Range
    Set timeTarget = Selection.Offset(direction)
    timeTarget.Select
End Sub

Private Sub MoveHorizontal(ByVal direction As Long)
    Dim timeTarget As Range
    Set timeTarget = Selection.Offset(, direction)
    timeTarget.Select
End Sub

The meat of it

Public Sub Main(ByVal currentLocation As Range, ByVal targetLocation As Range)
    Dim snakeString As String
    snakeString = Range("PathString").value
    Dim snakePath() As Range
    GetRangesFromString snakePath(), snakeString
    Dim isLegal As Boolean
    isLegal = True
    Dim verticalMovement As Long
    Dim horizontalMovement As Long
    horizontalMovement = CalculateMovement(targetLocation.Column, currentLocation.Column)
    verticalMovement = CalculateMovement(targetLocation.Row, currentLocation.Row)

    isLegal = CheckLegal(verticalMovement, horizontalMovement)
    If Not isLegal Then
        Range("LegalMove") = ILLEGAL
        currentLocation.Select
        Exit Sub
    End If

    Dim canMove As Boolean
    canMove = False
    If Not IsEmpty(targetLocation) Then
        canMove = CanContinue(targetLocation)
        If Not canMove Then
            Stop_Timing
            MsgBox "SCORE: " & UBound(snakePath)
            ResetBoard
            Exit Sub
        End If
        targetLocation.Interior.Color = xlNone
        PlaceMouse
    End If

    DrawSnakeHead targetLocation, horizontalMovement, verticalMovement
    Range("Position") = targetLocation.Row & DELIMITER & targetLocation.Column

    If UBound(snakePath) > 0 Then currentLocation.value = Chr$(BODY_SEGMENT)

    Range("HorizontalMovement").value = horizontalMovement
    Range("VerticalMovement").value = verticalMovement

    If canMove Then
        ReDim Preserve snakePath(LBound(snakePath) To UBound(snakePath) + 1)
    Else
        redraw snakePath()
    End If

    Set snakePath(UBound(snakePath)) = targetLocation
    snakeString = WritePath(snakePath)
    Range("PathString") = Replace(snakeString, "$", vbNullString)


End Sub

Private Sub GetRangesFromString(ByRef snakePath() As Range, ByVal snakeString As String)
    Dim snakePathString As Variant
    snakePathString = Split(snakeString, DELIMITER)
    ReDim snakePath(LBound(snakePathString) To UBound(snakePathString))
    Dim index As Long
    For index = LBound(snakePathString) To UBound(snakePathString)
        Set snakePath(index) = Range(snakePathString(index))
    Next
End Sub

Private Function CalculateMovement(ByVal ending As Long, ByVal beginning As Long) As Long
    If ending > beginning Then
        CalculateMovement = 1
    ElseIf beginning > ending Then
        CalculateMovement = -1
    Else
        CalculateMovement = 0
    End If
End Function

Private Function CheckLegal(ByVal verticalMovement As Long, ByVal horizontalMovement As Long) As Boolean
    If horizontalMovement = 0 Then
        If verticalMovement + Range("VerticalMovement") = 0 Then
            CheckLegal = ILLEGAL
            Exit Function
        Else
            CheckLegal = LEGAL
        End If
    ElseIf verticalMovement = 0 Then
        If horizontalMovement + Range("HorizontalMovement") = 0 Then
            CheckLegal = ILLEGAL
            Exit Function
        Else
            CheckLegal = LEGAL
        End If
    End If
End Function

Private Function CanContinue(ByVal targetLocation As Range) As Boolean
    If InStr(1, targetLocation.value, Chr$(BODY_SEGMENT)) > 0 Then
        CanContinue = False
    Else
        CanContinue = True
    End If
End Function

Private Sub DrawSnakeHead(ByVal targetLocation As Range, ByVal horizontalMovement As Long, ByVal verticalMovement As Long)
    Dim head As Long
    If horizontalMovement = 0 Then
        If verticalMovement = -1 Then
            head = UP_CODE
        Else
            head = DOWN_CODE
        End If
    Else
        If horizontalMovement = 1 Then
            head = RIGHT_CODE
        Else
            head = LEFT_CODE
        End If
    End If
    targetLocation.value = Chr$(head)
End Sub

Private Sub redraw(ByRef snakePath() As Range)
    Dim index As Long
    snakePath(LBound(snakePath)).ClearContents
    For index = LBound(snakePath) To UBound(snakePath) - 1
        Set snakePath(index) = snakePath(index + 1)
    Next
End Sub

Private Function WritePath(ByRef snakePath() As Range) As String
    Dim index As Long
    Dim tempString As String
    For index = LBound(snakePath) To UBound(snakePath)
        tempString = tempString & DELIMITER & snakePath(index).Address
    Next
    WritePath = Right$(tempString, Len(tempString) - 1)
End Function
\$\endgroup\$
  • \$\begingroup\$ So, I suppose what's working is working as intended then? Wouldn't Application.OnTime work for the game loop? \$\endgroup\$ – Mathieu Guindon Feb 28 '17 at 17:55
  • 2
    \$\begingroup\$ Not sure what's up with your picture, but this post really needs a screenshot (aka see it to believe it) ;-) \$\endgroup\$ – Mathieu Guindon Feb 28 '17 at 17:56
  • 5
    \$\begingroup\$ This is very cool! If I has any knowledge of VBA I would definitely review this! \$\endgroup\$ – Thijs Riezebeek Mar 2 '17 at 9:20
  • \$\begingroup\$ @Mat'sMug I went ghetto style and took video of my screen and put it up on youtube, it's linked at the image now ;) \$\endgroup\$ – Raystafarian Mar 2 '17 at 16:43
  • \$\begingroup\$ Nice ideia!!! Timing seams to be a problem, as my Excel only triggers OnTime at exact seconds (so snake is rather slow!!!) But we can workaround it... \$\endgroup\$ – LS_ᴅᴇᴠ Aug 28 '17 at 8:58
2
\$\begingroup\$

VBA is totally meant for this!! One of the first programs I built in VBA was a snake game. (the following code snippets are from my game)

Here's how I handled some of the things you struggled with.

direction change. For the direction change I used the GetAsyncKeyState API

Public Declare Function GetAsyncKeyState Lib "user32.dll" (ByVal nVirtKey As Long) As Integer
Public Const KeyPressed As Integer = -32767

And in a method, one of the four direction changes.

    If GetAsyncKeyState(vbKeyRight) = KeyPressed Then
        If direction = "U" Or direction = "D" Then
            direction = "R"
            DoEvents
            Exit For
        End If
    End If
    ....

End of snake, growing snake, path of snake This is actually fairly easy, make your snake an array and only handle the upper and lower bound parts of the array. When the upper bound part of the array lands on a new cell check to see if there is an existing thing in it like a mouse, a wall, or anything else to make a decision. Ultimately change the upper bound color to say green and the lower bound color to nothing. This is how your snake will move around.

This method shows the snake movement, it's doing a few other things so take from it what you will:

Private Sub moveSnake() 'This is where it all happens
Dim i As Integer

'Moves the snake in the direction that the key was pressed
Select Case direction
    Case "R"
        ReDim Preserve snake(UB)
        Set snake(UB) = snake(UB - 1).Offset(0, 1)
    Case "L"
        ReDim Preserve snake(UB)
        Set snake(UB) = snake(UB - 1).Offset(0, -1)
    Case "U"
        ReDim Preserve snake(UB)
        Set snake(UB) = snake(UB - 1).Offset(-1, 0)
    Case "D"
        ReDim Preserve snake(UB)
        Set snake(UB) = snake(UB - 1).Offset(1, 0)
End Select

'End game if snake hits a wall
If snake(UB).Interior.Color = black Then
    MsgBox "Splat!!! You hit a wall and died!"
    gameEnd = True
    Call endGame
    Exit Sub
End If

'End game if snake bites its tail
For i = LB + 1 To UB - 1
    If snake(UB).Interior.Color <> red Then
        If snake(LB).Address = snake(i).Address Then disapearingTail = True
        If snake(UB).Address = snake(i).Address Then
            MsgBox "Chomp!!! You bit your tail and died"
            gameEnd = True
            Call endGame
        End If
    End If
Next

'Enable exit if all food has been eaten
If eatCount = foodCount Then
    If level = 10 Then [AM80:AO80].Interior.Color = Other
    If level = 8 Then [BY39:CB39].Interior.Color = white
    [CB38:CB40].Interior.Color = white
    [CC38] = "Exit Here"
    eatCount = 0
End If

'Here's where all the action happens
Select Case snake(UB).Interior.Color
    Case Is = blue
        snake(UB).Interior.Color = green
        UB = UB + 1
        ReDim Preserve snake(UB)
        Set snake(UB) = snake(UB - 1)
        points = points + 10
        [CC24] = points
        newLength = newLength + 1
        eatCount = eatCount + 1
    Case Is = yellow
        snake(UB).Interior.Color = green
        snake(LB).Interior.Color = white
        points = points + 100
        [CC24] = points
        UB = UB + 1
        LB = LB + 1
    Case Is = red
        Call teleport
        snake(LB).Interior.Color = white
        UB = UB + 1
        LB = LB + 1
    Case Is = Other
        If snake(LB).Interior.Color = Other Then
            newLevel = True
            points = points + 50
            [CC24] = points
            MsgBox "You Found the Secret Level!!!!", , "SECRET LEVEL"
            Call secretLevel
            Exit Sub
        End If
        Set snake(UB) = snake(UB - 1)
        UB = UB - 1
        ReDim Preserve snake(UB)
        If snake(LB).Interior.Color <> red Then
            snake(LB).Interior.Color = white
        End If
        eatOther = True
    Case Is = grey
        If snake(LB).Interior.Color = grey Then
            newLevel = True
            points = points + 50
            [CC24] = points
            MsgBox "Level " & level & "-" & subLevel & " complete!!", vbOKCancel, "Go to Next Level"
            level = level + 1
            If level >= 11 Then
                level = 1
                If subLevel = 3 And level = 10 Then MsgBox "There is a Secret Level in this Game. Look for the off color.", , "Hint"
                If subLevel = 5 And level = 10 Then MsgBox "If you have not found the secret yet, look at the bottom", , "Hint"
                If subLevel = 7 And level = 10 Then MsgBox "If you still haven't found it it is on the bottom of the screen" _
                    & "after eating all sqrs on the 10th level.", , "Hint"
                subLevel = subLevel + 1
                If delay <> 4 Then
                    delay = delay - 2
                    [CC24] = points
                End If
            End If
            Call selectLevel  'Start New Level
            Exit Sub
        End If
        Set snake(UB) = snake(UB - 1)
        UB = UB - 1
        ReDim Preserve snake(UB)
        If snake(LB).Interior.Color <> red Then
            snake(LB).Interior.Color = white
        End If
        eatOther = True
    Case Else
        If newLevel Then  'this happens at start of new level
            If UB <> newLength Then
                snake(UB).Interior.Color = green
                UB = UB + 1
                ReDim Preserve snake(UB)
                Set snake(UB) = snake(UB - 1)
            Else
                newLevel = False
            End If
        Else 'Process regular movement around screen
            snake(UB).Interior.Color = green
            If snake(LB).Interior.Color <> red And snake(LB).Interior.Color <> blue Then
                If Not disapearingTail Then
                    snake(LB).Interior.Color = white
                End If
            End If
            UB = UB + 1
            LB = LB + 1
            disapearingTail = False
        End If
End Select

End Sub

Don't know if that helps on anything, but I couldn't pass up the chance to comment on this post. If anyone likes I could post all of the source code.

\$\endgroup\$
  • \$\begingroup\$ Thanks, those are definitely some things to consider. I like the direction function, didn't even consider it \$\endgroup\$ – Raystafarian Nov 30 '17 at 0:46

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.