VB Source Code for Snakeman | A Game Written in Microsoft Excel

code.vba

Option Explicit
Const ms As Double = 0.000000011574
Public snakeX As Integer
Public snakeY As Integer
Public snakePos As Object
Public snakeLen As Integer
Public direction As Integer
Public gameState As Integer
Public roundNum As Integer

Public word As String
Public rightLetters As New Collection
Public wrongLetters As New Collection
Public lettersLeft As New Collection

Public boardLetters As New Collection

Private Sub Worksheet_Activate()
    Worksheets("Game").Activate
    Application.OnKey "{UP}", "up"
    Application.OnKey "{DOWN}", "down"
    Application.OnKey "{LEFT}", "left"
    Application.OnKey "{RIGHT}", "right"
    Do
        If gameState = 1 Then
            Do
                update
                render
                WaitFor (0.5)
            Loop Until gameState <> 1
            endGame
        End If
        WaitFor (1)
    Loop Until False
End Sub

Sub startStopClick()
    If gameState <> 1 Then
        initGame
    Else
        gameState = 2
    End If
End Sub

Sub WaitFor(NumOfSeconds As Single)
    Dim SngSec As Single
    SngSec = Timer + NumOfSeconds

    Do While Timer < SngSec
        DoEvents
   Loop
End Sub

Sub up()
    direction = 0
End Sub

Sub down()
    direction = 1
End Sub

Sub left()
    direction = 2
End Sub

Sub right()
    direction = 3
End Sub

Sub initGame()
    gameState = 1
    ActiveSheet.Buttons(1).Text = "Stop"
    snakeLen = 1
    roundNum = 0
    nextRound
End Sub

Sub nextRound()
    Dim gameId
    Set gameId = Worksheets("Data").range("B1").Cells
    Dim hReq
    Set hReq = CreateObject("MSXML2.XMLHTTP")
    With hReq
        .Open "GET", "https://api.theturkey.dev/randomword?id=" + CStr(gameId.Value), False
        .Send
    End With
    word = UCase(hReq.ResponseText)
    gameId.Value = gameId.Value + 1
    
    roundNum = roundNum + 1
    ActiveSheet.range("R1").Value = roundNum
    snakeX = 8
    snakeY = 8
    direction = -1
    
    RemoveAll rightLetters
    RemoveAll wrongLetters
    RemoveAll lettersLeft
    Set snakePos = CreateObject("System.Collections.Queue")
    
    Dim alphabet, i
    alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    For i = 1 To Len(alphabet)
        lettersLeft.Add Mid(alphabet, i, 1)
    Next
    
    clearHangman
    randomizeBoardLetters
End Sub

Sub randomizeBoardLetters()
    RemoveAll boardLetters
    Dim i As Integer
    Dim letter
    For i = 1 To WorksheetFunction.Min(10, lettersLeft.Count)
        Set letter = New boardLetter
        Do
            letter.col = Int((15 * Rnd) + 1)
            letter.row = Int((15 * Rnd) + 1)
        Loop While ContainsBoardLetterAt(letter.row, letter.col)
        
        Do
            letter.letter = lettersLeft(Int((lettersLeft.Count * Rnd) + 1))
        Loop While ContainsBoardLetter(letter.letter)
         
        boardLetters.Add letter
    Next
    
    Set letter = New boardLetter
    Do
        letter.col = Int((15 * Rnd) + 1)
        letter.row = Int((15 * Rnd) + 1)
    Loop While ContainsBoardLetterAt(letter.row, letter.col)
    
    letter.letter = "#"
    boardLetters.Add letter

    Dim c
    For Each c In ActiveSheet.range(Cells(1, 1), Cells(15, 15)).Cells
        Dim bl As boardLetter
        Set bl = GetBoardLetterAt(c.Column, c.row)
        If Not bl Is Nothing Then
            c.Value = bl.letter
        Else
            c.Value = ""
        End If
    Next
End Sub

Sub endGame()
    Dim c
    For Each c In ActiveSheet.range(Cells(1, 1), Cells(15, 15)).Cells
        c.Value = ""
    Next
    ActiveSheet.Buttons(1).Text = "Start"
    
    MsgBox "Game Over! The word was " + word
End Sub

Sub updateHangman()
    If wrongLetters.Count = 1 Then
        setBorder "V4", xlEdgeTop
        setBorder "V4", xlEdgeLeft
        setBorder "W4", xlEdgeTop
        setBorder "W4", xlEdgeRight
        setBorder "V5", xlEdgeBottom
        setBorder "V5", xlEdgeLeft
        setBorder "W5", xlEdgeBottom
        setBorder "W5", xlEdgeRight
    ElseIf wrongLetters.Count = 2 Then
        setBorder "W6:W9", xlEdgeLeft
    ElseIf wrongLetters.Count = 3 Then
        setBorder "V7", xlDiagonalDown
        setBorder "U6", xlDiagonalDown
    ElseIf wrongLetters.Count = 4 Then
        setBorder "W7", xlDiagonalUp
        setBorder "X6", xlDiagonalUp
    ElseIf wrongLetters.Count = 5 Then
        setBorder "W10", xlDiagonalDown
        setBorder "X11", xlDiagonalDown
    ElseIf wrongLetters.Count = 6 Then
        setBorder "U11", xlDiagonalUp
        setBorder "V10", xlDiagonalUp
    End If
End Sub

Sub clearHangman()
    removeBorder "V4", xlEdgeTop
    removeBorder "V4", xlEdgeLeft
    removeBorder "W4", xlEdgeTop
    removeBorder "W4", xlEdgeRight
    removeBorder "V5", xlEdgeBottom
    removeBorder "V5", xlEdgeLeft
    removeBorder "W5", xlEdgeBottom
    removeBorder "W5", xlEdgeRight
    removeBorder "W6:W9", xlEdgeLeft
    removeBorder "V7", xlDiagonalDown
    removeBorder "U6", xlDiagonalDown
    removeBorder "W7", xlDiagonalUp
    removeBorder "X6", xlDiagonalUp
    removeBorder "W10", xlDiagonalDown
    removeBorder "X11", xlDiagonalDown
    removeBorder "U11", xlDiagonalUp
    removeBorder "V10", xlDiagonalUp
End Sub

Sub setBorder(range As String, border As Integer)
    With ActiveSheet.range(range).Borders(border)
    .LineStyle = xlContinuous
    .Weight = xlMedium
    End With
End Sub

Sub removeBorder(range As String, border As Integer)
    With ActiveSheet.range(range).Borders(border)
    .LineStyle = xlNone
    End With
End Sub

Sub update()
    Dim toAdd As New pos
    toAdd.col = snakeX
    toAdd.row = snakeY
    If Not direction = -1 Then
        snakePos.Enqueue toAdd
    End If
    Do While snakePos.Count > snakeLen - 1
        snakePos.Dequeue
    Loop
       
    If direction = 0 Then
        snakeY = snakeY - 1
    ElseIf direction = 1 Then
        snakeY = snakeY + 1
    ElseIf direction = 2 Then
        snakeX = snakeX - 1
    ElseIf direction = 3 Then
        snakeX = snakeX + 1
    End If
    
    If snakeX < 1 Or snakeX > 15 Or snakeY < 1 Or snakeY > 15 Then
        gameState = 2
    ElseIf ContainsSnakePos(snakeY, snakeX) Then
        gameState = 2
    Else
        Dim bl As boardLetter
        Set bl = GetBoardLetterAt(snakeX, snakeY)
        If Not bl Is Nothing Then
            Dim removed As Boolean
            removed = RemoveBoardLetterAt(snakeX, snakeY)
            If bl.letter = "#" Then
                randomizeBoardLetters
            ElseIf InStr(word, bl.letter) Then
                rightLetters.Add bl.letter
                Dim roundWon, i, letter
                roundWon = True
                For i = 1 To Len(word)
                    letter = Mid(word, i, 1)
                    If Not Contains(rightLetters, letter) Then
                        roundWon = False
                    End If
                Next
                
                If roundWon Then
                    nextRound
                End If
            ElseIf Not Contains(wrongLetters, bl.letter) Then
                wrongLetters.Add bl.letter
                snakeLen = snakeLen + 1
                updateHangman
            End If
            
            RemoveLetter bl.letter
            ActiveSheet.Cells(snakeY, snakeX).Value = ""
        End If
    End If
    
    If wrongLetters.Count = 6 Then
        gameState = 2
    End If
End Sub

Sub render()
    Application.ScreenUpdating = False
    Dim c
    For Each c In ActiveSheet.range(Cells(1, 1), Cells(15, 15)).Cells
        If c.Column = snakeX And c.row = snakeY Then
            c.Interior.Color = RGB(146, 245, 86)
        ElseIf ContainsSnakePos(c.row, c.Column) Then
            c.Interior.Color = RGB(108, 187, 60)
        ElseIf (c.Column + c.row) Mod 2 = 0 Then
            c.Interior.Color = RGB(169, 208, 142)
        Else
            c.Interior.Color = RGB(198, 224, 180)
        End If
    Next
    Dim dispWord As String
    Dim i As Long
    Dim letter
    dispWord = ""
    For i = 1 To Len(word)
        letter = Mid(word, i, 1)
        If Contains(rightLetters, letter) Then
            dispWord = dispWord + letter + " "
        Else
            dispWord = dispWord + "_ "
        End If
    Next
    ActiveSheet.range("AA5").Value = dispWord
    
    dispWord = ""
    For i = 1 To wrongLetters.Count
        dispWord = dispWord + wrongLetters(i) + " "
    Next
    ActiveSheet.range("AA7").Value = dispWord
    
    Application.ScreenUpdating = True
End Sub


Public Function Contains(col As Collection, key As Variant) As Boolean
    Dim k
    For Each k In col
        If k = key Then
            Contains = True
            Exit Function
        End If
    Next
    Contains = False
End Function

Public Function ContainsBoardLetterAt(row As Integer, col As Integer) As Boolean
    Dim letter As boardLetter
    For Each letter In boardLetters
        If letter.col = col And letter.row = row Then
            ContainsBoardLetterAt = True
            Exit Function
        End If
    Next
    ContainsBoardLetterAt = False
End Function

Public Function ContainsBoardLetter(l As String) As Boolean
    Dim letter As boardLetter
    For Each letter In boardLetters
        If letter.letter = l Then
            ContainsBoardLetter = True
            Exit Function
        End If
    Next
    ContainsBoardLetter = False
End Function

Public Function GetBoardLetterAt(row As Integer, col As Integer) As boardLetter
    Dim letter As boardLetter
    For Each letter In boardLetters
        If letter.col = col And letter.row = row Then
            Set GetBoardLetterAt = letter
            Exit Function
        End If
    Next
    Set GetBoardLetterAt = Nothing
End Function

Public Function RemoveBoardLetterAt(row As Integer, col As Integer) As Boolean
    Dim i As Integer
    For i = 1 To boardLetters.Count
        Dim letter As boardLetter
        Set letter = boardLetters(i)
        If letter.col = col And letter.row = row Then
            boardLetters.Remove i
            RemoveBoardLetterAt = True
            Exit Function
        End If
    Next
     RemoveBoardLetterAt = False
End Function

Public Function ContainsSnakePos(row As Integer, col As Integer) As Boolean
    Dim p As pos
    For Each p In snakePos
        If p.col = col And p.row = row Then
            ContainsSnakePos = True
            Exit Function
        End If
    Next
    ContainsSnakePos = False
End Function

Sub RemoveAll(ByRef coll As Collection)
    Dim i As Long
    For i = coll.Count To 1 Step -1
        coll.Remove i
    Next i
End Sub

Sub RemoveLetter(letter As String)
    Dim i As Long
    For i = lettersLeft.Count To 1 Step -1
        If lettersLeft(i) = letter Then
            lettersLeft.Remove i
        End If
    Next i
End Sub