Snake in Excel in... VBA?

Question

snake-game 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 = "$P16ドル"
 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

• Mathieu Guindon: So, I suppose what's working is working as intended then? Wouldn't Application.OnTime work for the game loop?
• Mathieu Guindon: Not sure what's up with your picture, but this post really needs a screenshot (aka see it to believe it) ;-)
• Thijs Riezebeek: This is very cool! If I has any knowledge of VBA I would definitely review this!
• Raystafarian: @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 ;)
• LS_ᴅᴇᴠ: 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...

Answer 1

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.

• Raystafarian: Thanks, those are definitely some things to consider. I like the direction function, didn't even consider it

Answer 2

Under DrawGameBoard, when you set your game range to be

Set gameRange = .Range("B2:AD31")

Shouldn't it be to cell AE31? Otherwise resetting the board won't clear the rightmost column.