5
\$\begingroup\$

Multithreaded Excel + VBScript Timer

After reviewing these post: Snake in Excel in… VBA? and Drawing a snake using arrow keys in Excel using VBA, I decided to work on creating a VBA Timer.

The typical Timers patterns used in the VBA have serious drawbacks.

  • API Sleep - Stops the code execution until the sleep period is over
  • API Callback - Will abruptly quit Excel if you are editing a cell, in break mode or if you are not holding your mouth right
  • Do While True Loops - Uses a lot of resources. Generally, one of your CPUs usage will go dramatically increase. Considering that the VBA isn't multithreaded this is a significant drawback

Download Multithreaded Excel VBScript Timer - Snake Game.xlsm

Snake Game Demo

This Gif was recorded at 15 fps per second. The Game was set to Updates every 100ms. The actual game is smoother that the GIF.

This Timer seems to be functioning quite well without any of the drawbacks listed above. I don't like the fact that it requires requires a callback function in a public module, but don't think that there is any way around it. I might end getting rid of the Timer class altogether and just use a single public module.

I'm looking for ways to improve the Timer and would apreciate any feedback

Public Module: Callback and setSheetView Function

Public Function Timer_Tick(Optional KeyCode As Integer) As Boolean
    If Not Game Is Nothing Then
        Game.Timer1.Update
        Timer_Tick = True
    End If
End Function

Public Sub setSheetView(Optional Maximize As Boolean)
    Application.DisplayFullScreen = Maximize
    ActiveWindow.DisplayHeadings = Not Maximize
    ActiveWindow.DisplayGridlines = Not Maximize
    Application.DisplayFormulaBar = Not Maximize
    If Maximize Then
        Application.Cursor = xlIBeam
        wsMap.Protect UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True
        wsMap.EnableSelection = xlNoSelection
    Else
        Application.Cursor = xlDefault
        wsMap.Unprotect
    End If
End Sub

Class: TimerClass

Option Explicit
'MULTITHREADING VBA USING VBSCRIPT: http://analystcave.com/excel-multithreading-in-vba-using-vbscript/
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private mKeysPressed(1 To 127) As Boolean
Public Event Update(KeysPressed() As Boolean)
Public isRunning As Boolean
Public Speed As Long
Public TimerScript As String

Public Sub Stop_Timer()
    isRunning = False
    DeleteScript
End Sub

Public Sub Start_Timer()
    isRunning = True
    RunScript
End Sub

Private Sub RunScript()
    Dim fso As Object, wsh As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    DeleteScript
    TimerScript = fso.BuildPath(Environ("Temp"), Replace(fso.GetTempName, "tmp", "vbs"))

    With fso.CreateTextFile(TimerScript, True)
        .WriteLine "On Error Resume Next"
        .WriteLine "Const ScriptFullName = " & Chr(34) & TimerScript & Chr(34)
        .WriteLine "Const wbFullName = " & Chr(34) & ThisWorkbook.FullName & Chr(34)
        .WriteLine "Dim wb"
        .WriteLine "Set wb = WScript.GetObject(wbFullName)"
        .WriteLine "If Err.Number <> 0 Then DeleteMe"
        .WriteLine "Do While wb.Application.Run(""Timer_Tick"")"
        .WriteLine "    WScript.Sleep(" & Speed & ")"
        .WriteLine "    If Err.Number <> 0 Then DeleteMe"
        .WriteLine "Loop"
        .WriteLine "DeleteMe"
        .WriteLine "Sub DeleteMe"
        .WriteLine "    On Error Resume Next"
        .WriteLine "    Dim fso"
        .WriteLine "    Set fso = CreateObject(""Scripting.FileSystemObject"")"
        .WriteLine "    fso.DeleteFile ScriptFullName,True"
        .WriteLine "    WScript.Quit"
        .WriteLine "End Sub"
        .Close
'        Debug.Print TimerScript
'        Debug.Print fso.OpenTextFile(TimerScript).ReadAll
    End With

    Set wsh = VBA.CreateObject("WScript.Shell")
    On Error Resume Next
    wsh.Run """" & TimerScript & """"
    On Error GoTo 0
    Set wsh = Nothing
End Sub

Private Sub DeleteScript()
    On Error Resume Next
    If Len(Dir(TimerScript)) > 0 And Len(TimerScript) > 0 Then CreateObject("Scripting.FileSystemObject").DeleteFile TimerScript, True
    On Error GoTo 0
End Sub

Public Sub Update()
    Dim x As Long
    For x = LBound(mKeysPressed) To UBound(mKeysPressed)
        mKeysPressed(x) = GetAsyncKeyState(x)
    Next
    RaiseEvent Update(mKeysPressed)
End Sub

wsMap Sheet Module: Start Button

Private Sub btnStart_Click()
    If Game Is Nothing Then
        Set Game = New GameClass
        Set Game.Button = btnStart
        Game.Start
    Else
        Set Game = Nothing
    End If
End Sub

Class: GameClass

Option Explicit
Private colOffset As Long, rowOffset As Long
Private Direction As Integer
Private Food As Variant
Private FoodCount As Long
Private Foods As Object
Private GrassMap As Range
Private Grass_Color As Long
Private Head As Range
Private Segments As Object
Private SnakeHead As String
Private SnakeSegment As String
Private SpawnLocations As Object
Private Water_Color As Long
Public WithEvents Timer1 As TimerClass
Public Button As MSForms.CommandButton

'OBJECT ORIENTED VBA: DESIGN PATTERNS: THE SINGLETON (https://hammondmason.wordpress.com/2015/07/15/object-oriented-vba-design-patterns-the-singleton/)
Private Sub Class_Initialize()
    Application.ScreenUpdating = False
    If Not Game Is Nothing Then
        Err.Raise 1 + vbObjectError, "Factory.Instantiate", "Instantiation failed. There already exists an instance of Game Loop"
        Exit Sub
    End If
    Set Game = Me
    'Initiate Objects
    Set Foods = CreateObject("System.Collections.ArrayList")
    Set Segments = CreateObject("System.Collections.ArrayList")
    Set SpawnLocations = CreateObject("System.Collections.ArrayList")
    Set Timer1 = New TimerClass
    'Initiate Settings
    Food = Range("Food").Value
    FoodCount = Range("FoodCount").Value
    Grass_Color = Range("Grass").Interior.Color
    Water_Color = Range("Water").Interior.Color       'Unsupported
    SnakeSegment = Chr(173)
    SnakeHead = Chr(233)
    Set Head = wsMap.Range(Range("StartAddress").Value)
    CenterOnCell Head
    'Defines Playable Area
    Init_Lists
    'Apply Settings
    Timer1.Speed = Range("Speed").Value * 100
    Range("Length").Value = 1
    Range("Updates").Value = 0
    'Spawn Food
    Spawn_Food
    Head.Value = SnakeHead
    Application.ScreenUpdating = True
End Sub

Private Sub Class_Terminate()
    setSheetView False
    Timer1.Stop_Timer
    MsgBox "Game Over", vbInformation, ""
    Button.Caption = "Start"
End Sub

'Based on Chip Pearson: http://www.cpearson.com/excel/zoom.htm
Private Sub CenterOnCell(cell As Range)
    Dim ScrollColumn As Long, ScrollRow As Long
    On Error Resume Next
    With ActiveWindow.VisibleRange
        ActiveWindow.ScrollColumn = cell.Column - .Columns.Count / 2
        ActiveWindow.ScrollRow = cell.Row - .Rows.Count / 2
    End With
    On Error GoTo 0
End Sub

Function getRange(IList As Object) As Range
    Dim cell As Variant, Target As Range
    If TypeName(cell) = "String" Then Set cell = wsMap.Range(cell)

    For Each cell In IList
        If Target Is Nothing Then
            Set Target = cell
        Else
            Set Target = Union(Target, cell)
        End If
    Next

    Set getRange = Target
End Function

Private Sub Init_Lists()
    Dim cell As Range
    For Each cell In wsMap.UsedRange
        If cell.Interior.Color = Grass_Color Then
            If GrassMap Is Nothing Then
                Set GrassMap = cell
            Else
                Set GrassMap = Union(GrassMap, cell)
            End If

            SpawnLocations.Add cell
            cell.ClearContents
        End If
    Next
End Sub

Public Sub Spawn_Food()
    Dim n As Long
    Dim list As Object, cell As Range
    Set list = SpawnLocations.Clone

    Do Until list.Count = 0 Or Foods.Count = FoodCount
        n = (list.Count * Rnd)
        Set cell = list(n)
        If Len(cell.Value) = 0 Then
            cell.Value = Food
            Foods.Add cell.Address
        End If
    Loop
End Sub

Public Sub Start()
    Button.Caption = "Stop"
    Timer1.Start_Timer
    setSheetView True
End Sub

Private Sub Timer1_Update(KeysPressed() As Boolean)

    With Timer1
        If KeysPressed(vbKeyEscape) Then
            Set Game = Nothing
        ElseIf KeysPressed(vbKeyRight) And KeysPressed(vbKeyUp) Then
            colOffset = 1: rowOffset = -1: SnakeHead = Chr(236)
        ElseIf KeysPressed(vbKeyRight) And KeysPressed(vbKeyDown) Then
            colOffset = 1: rowOffset = 1: SnakeHead = Chr(238)
        ElseIf KeysPressed(vbKeyLeft) And KeysPressed(vbKeyUp) Then
            colOffset = -1: rowOffset = -1: SnakeHead = Chr(235)
        ElseIf KeysPressed(vbKeyLeft) And KeysPressed(vbKeyDown) Then
            colOffset = -1: rowOffset = 1: SnakeHead = Chr(237)
        ElseIf KeysPressed(vbKeyLeft) Then
            colOffset = -1: rowOffset = 0: SnakeHead = Chr(231)
        ElseIf KeysPressed(vbKeyRight) Then
            colOffset = 1: rowOffset = 0: SnakeHead = Chr(232)
        ElseIf KeysPressed(vbKeyDown) Then
            colOffset = 0: rowOffset = 1: SnakeHead = Chr(234)
        ElseIf KeysPressed(vbKeyUp) Then
            colOffset = 0: rowOffset = -1: SnakeHead = Chr(233)
        End If
    End With

    If Head.Row + rowOffset < 1 Or Head.Column + colOffset < 1 _
       Or Head.Row + rowOffset > wsMap.Rows.Count Or Head.Column + colOffset > wsMap.Columns.Count Then
        Set Game = Nothing
    ElseIf Intersect(Head.Offset(rowOffset, colOffset), GrassMap) Is Nothing Then
        Set Game = Nothing
    Else
        If Segments.Count > 0 Then If Not Intersect(Head.Offset(rowOffset, colOffset), getRange(Segments)) Is Nothing Then Set Game = Nothing
        Segments.Add Head
        getRange(Segments).ClearContents
        With Head.Offset(rowOffset, colOffset)
            If Not .Value = Food Then
                Segments.RemoveAt 0
                Spawn_Food
            End If
            Set Head = .Cells
        End With

        If Segments.Count > 0 Then getRange(Segments).Value = SnakeSegment
        Range("Length").Value = Segments.Count + 1
        Head.Value = SnakeHead
        CenterOnCell Head
    End If
    Range("Updates").Value = Range("Updates").Value + 1

End Sub

Miscellaneous Settings and Names Ranges

enter image description here

\$\endgroup\$

0

Reset to default