Excel VBA Multiplayer Tetris Game Loop Repaint Rate

Question

While searching VBA Excel Tetris games online, I noticed several single player Tetris games but no multiplayer games.

I am looking for a better strategy to manage the speed of the Application and to eliminate the flickering caused by toggling Application.ScreenUpdating.

Not toggling Application.ScreenUpdating will all but eliminate the flickering that you see in the Gif below. It will still flicker some while playing a 4 player game. The problem with this is that it increases the amount of time it takes for the Do Loop to cycle.

I count each cycles as a tick and check for key presses and repaint the board based on these ticks. Hence, as the ticks per second changes depending on toggling Application.ScreenUpdating or the number of player so does the games performance.

Ticks per second

Here is a download link for my Workbook:Multiplayer Tetris 2.0

This is my choice for the best Excel Tetris:Excel Tetris - CosmicAdventure

Single Player

4 Players

Game Loop

In order to even out the performance,I think that I need to calculate a Cycles Per Second (CPS) rate and increase the ticks uniformly based of the CPS.

Do
    Ticks = Ticks + 1

    If GetAsyncKeyState(vbKeyEnd) Then setGameState gsPaused

    If AppGameState = gsRunning Then
        If Ticks Mod 2000 = 0 Then
            For n = 0 To UBound(Players)
                CheckKeys Players(n)
                Players(n).Ticks = Players(n).Ticks + 1
            Next
        End If

        If Ticks Mod 4000 = 0 Then
            For n = 0 To UBound(Players)
                If (Players(n).Ticks + Players(n).Speed) > 10 Then
                    Players(n).Ticks = 0
                    AutoMoveTetromino Players(n)
                End If
                DrawBoard Players(n)
                ConsolidateGrid Players(n)
            Next
        End If
    ElseIf AppGameState = gsGameOver Then
        GameOver Players
        wsTetris.tglPauseGame.Caption = "Pause"
        wsTetris.tglPauseGame.Value = False
        setSheetView False
        End
    End If

    DoEvents
Loop

wsTetris: Worksheet Module

Private Sub btnGameOver_Click()
    setGameState gsGameOver
    tglPauseGame.Caption = "Pause"
    tglPauseGame.Value = False
End Sub

Private Sub btnSettings_Click()
    PlayerSettingsForm.Show
End Sub

Private Sub btnStartGame_Click()
    setGameState gsNewGame
    tglPauseGame.Caption = "Pause"
    tglPauseGame.Value = False
    StartGame
End Sub

Private Sub tglPauseGame_Click()
    If tglPauseGame Then
        setGameState gsPaused
        tglPauseGame.Caption = "Resume"
    Else
        setGameState gsRunning
        tglPauseGame.Caption = "Pause"
    End If
End Sub

GameModule: Public Module

Private Const GRID_HEIGHT = 22 - 1                    '-1 to adjust for Option Base 0
Private Const GRID_WIDTH = 10 - 1                     ' -1 to adjust for Option Base 0
Private Const STYLE_PREFIX = "Block"
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Public Enum GameState
    gsNewGame
    gsGameOver
    gsRunning
    gsPaused
End Enum

Private AppGameState As GameState
Public Type Tetromino
    ID As Long                                        'Block Index
    X As Long                                         'Column Offset
    Y As Long                                         'Row Offset
    Z As Long                                         'Rotation Index
End Type

Public Type Player
    CurrTetromino As Tetromino
    GameRange As Range
    Grid(0 To GRID_HEIGHT, 0 To GRID_WIDTH) As Long
    LevelRange As Range
    KeyDown As Long
    KeyLeft As Long
    KeyRight As Long
    KeyRotate As Long
    KeyShiftRotate As Long
    NameRange As Range
    PreviewTetromino As Tetromino
    NextTetromino As Tetromino
    PreviewRange As Range
    ScoreLines As Range
    ScoreRange As Range
    Speed As Single
    Ticks As Long
End Type

Private Sub AddPlayers(ByRef Players() As Player)
    Const SQL = "SELECT Player, [Player Name],[Preview-Top-Left-Cell],[Game-Top-Left-Cell], Speed, KeyRotate.Value AS KeyRotate, KeyLeft.Value AS KeyLeft, KeyRight.Value AS KeyRight, KeyDown.Value AS KeyDown, KeyShiftRotate.Value AS KeyShiftRotate " & _
          "FROM [KeyCodes$] AS KeyRotate INNER JOIN ([KeyCodes$] AS KeyShiftRotate INNER JOIN ([KeyCodes$] AS KeyDown INNER JOIN ([KeyCodes$] AS KeyRight INNER JOIN ([KeyCodes$] AS KeyLeft INNER JOIN [Player Settings$] ON KeyLeft.Description = [Player Settings$].Left) ON KeyRight.Description = [Player Settings$].Right) ON KeyDown.Description = [Player Settings$].Down) ON KeyShiftRotate.Description = [Player Settings$].[Shift Rotate]) ON KeyRotate.Description = [Player Settings$].Rotate " & _
          "WHERE ((([Player Name])<>""""));"
    Dim n As Long
    Dim Conn As Object, rs As Object
    Set Conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    Conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    Conn.Open
    rs.Open SQL, Conn

    If Not rs.BOF And Not rs.EOF Then
        ReDim Players(0)
        While (Not rs.EOF)
            ReDim Preserve Players(n)
            With Players(n)
                Set .GameRange = wsTetris.Range(rs("Game-Top-Left-Cell").Value).Resize(20, 10)
                Set .PreviewRange = wsTetris.Range(rs("Preview-Top-Left-Cell").Value).Resize(4, 4)
                .GameRange.Offset(2).Resize(20).Style = STYLE_PREFIX & 0
                .PreviewRange.Style = STYLE_PREFIX & 0
                setPlayerDefaultRanges Players(n), .NameRange, 5, "Player", rs("Player Name").Value
                setPlayerDefaultRanges Players(n), .ScoreRange, 7, "Score", 0
                setPlayerDefaultRanges Players(n), .ScoreLines, 9, "Lines", 0
                setPlayerDefaultRanges Players(n), .LevelRange, 11, "Level", 1
                .Speed = rs("Speed").Value
                .KeyRotate = rs("KeyRotate").Value
                .KeyLeft = rs("KeyLeft").Value
                .KeyRight = rs("KeyRight").Value
                .KeyDown = rs("KeyDown").Value
                .KeyShiftRotate = rs("KeyShiftRotate").Value
                .CurrTetromino = getTetromino
                .CurrTetromino.X = 4
                .CurrTetromino.Y = 3
                .PreviewTetromino = getTetromino
                DrawPreview Players(n)
            End With
            n = n + 1
            rs.MoveNext
        Wend
    End If
    rs.Close
    Conn.Close
End Sub

Private Function AutoMoveTetromino(ByRef p As Player)
    p.NextTetromino = p.CurrTetromino
    p.NextTetromino.Y = p.NextTetromino.Y + 1
    If isValidMove(p) Then
        MoveTetromino p
    Else
        SetTetromino p
        p.CurrTetromino = p.PreviewTetromino
        p.PreviewTetromino = getTetromino
        DrawPreview p
    End If
End Function

Private Function CheckKey(ByVal KeyCode As Long, ByRef t As Tetromino, ByVal X As Long, ByVal Y As Long, ByVal Z As Long)
    If GetAsyncKeyState(KeyCode) Then
        t.X = t.X + X
        t.Y = t.Y + Y
        t.Z = Switch(t.Z + Z < 0, 3, t.Z + Z > 3, 0, True, t.Z + Z)
        CheckKey = True
    End If
End Function

Private Sub CheckKeys(ByRef p As Player)
    With p
        .NextTetromino = .CurrTetromino
        If CheckKey(.KeyLeft, .NextTetromino, -1, 0, 0) Or _
           CheckKey(.KeyRight, .NextTetromino, 1, 0, 0) Or _
           CheckKey(.KeyDown, .NextTetromino, 0, 1, 0) Or _
           CheckKey(.KeyRotate, .NextTetromino, 0, 0, 1) Or _
           CheckKey(.KeyShiftRotate, .NextTetromino, 0, 0, -1) Then _
           If isValidMove(p) Then MoveTetromino p
    End With
End Sub

Private Sub ClearTetris()
    With wsTetris
        .Cells.ClearContents
        .Cells.Style = STYLE_PREFIX & 8
        .Cells.HorizontalAlignment = xlGeneral
        .Rows.RowHeight = 14.25
        .Columns.ColumnWidth = 2
        .Rows(1).Hidden = True
    End With
End Sub

Private Sub ConsolidateGrid(ByRef p As Player)
    Dim Count As Long, rowY As Long, v(0 To GRID_WIDTH) As Variant, vector(0 To GRID_HEIGHT) As Variant, X As Long, Y As Long
    Dim flag As Boolean
    rowY = GRID_HEIGHT
    For Y = GRID_HEIGHT To 0 Step -1
        flag = False
        For X = 0 To GRID_WIDTH
            v(X) = p.Grid(Y, X)
        Next

        If Application.WorksheetFunction.Max(v) > 0 Then
            If Application.WorksheetFunction.Min(v) = 0 Then
                vector(rowY) = v
                rowY = rowY - 1
            Else
                Count = Count + 1
            End If
        End If
    Next

    Erase p.Grid

    For Y = GRID_HEIGHT To 0 Step -1
        If IsArray(vector(Y)) Then
            For X = 0 To GRID_WIDTH
                p.Grid(Y, X) = CLng(vector(Y)(X))
            Next
        End If
    Next

    If Count > 0 Then
        rowY = GRID_HEIGHT - rowY
        p.ScoreLines = p.ScoreLines + Count
        p.ScoreRange = p.ScoreRange + (Count Mod 4) * 100 + Count * 10

        If p.ScoreLines >= 10 Then
            p.ScoreLines = p.ScoreLines - 10
            p.LevelRange.Value = p.LevelRange.Value + 1
        End If
    End If

End Sub

Private Sub DrawBoard(ByRef p As Player)
    Application.ScreenUpdating = False
    Dim ID As Long, X As Long, Y As Long
    Dim tRange As Range, t As Tetromino
    t = p.CurrTetromino
    With p
        Set tRange = Intersect(.GameRange.Offset(2), getBlockRange(.CurrTetromino, .GameRange))
    End With
    With p.GameRange
        For Y = 2 To GRID_HEIGHT
            For X = 0 To GRID_WIDTH
                With .Cells(1, 1).Offset(Y, X)
                    If Not tRange Is Nothing Then
                        If Intersect(tRange, .Cells) Is Nothing Then
                            .Style = STYLE_PREFIX & p.Grid(Y, X)
                        Else
                            .Style = STYLE_PREFIX & t.ID
                        End If
                    Else
                        .Style = STYLE_PREFIX & p.Grid(Y, X)
                    End If
                End With
            Next
        Next
    End With
    Application.ScreenUpdating = True
End Sub

Private Sub DrawPreview(ByRef p As Player)
    p.PreviewRange.Style = STYLE_PREFIX & 0
    getBlockRange(p.PreviewTetromino, p.PreviewRange).Style = STYLE_PREFIX & p.PreviewTetromino.ID
End Sub

Private Sub GameOver(ByRef Players() As Player)
    Dim Count As Long, MaxScore As Long, n As Long
    Dim Message As String, Title As String
    If UBound(Players) > 0 Then
        For n = 0 To UBound(Players)
            If MaxScore < Players(n).ScoreRange Then MaxScore = Players(n).ScoreRange.Value
            InsertScores Players(n)
        Next
        For n = 0 To UBound(Players)
            If MaxScore = Players(n).ScoreRange Then
                Message = Message & Players(n).NameRange.Value & vbTab & MaxScore & vbCrLf
                Count = Count + 1
            End If
        Next
    Else
        Message = Players(0).NameRange.Value & vbTab & Players(n).ScoreRange.Value
    End If
    Title = IIf(Count > 0, "Winner", "Winners")
    MsgBox Message, vbInformation, Title
End Sub

Private Function getBlockRange(ByRef t As Tetromino, Target As Range) As Range
    With Target.Cells(1, 1)
        Set getBlockRange = Union(.Offset(getY(t.ID, t.Z, t.Y, 1), getX(t.ID, t.Z, t.X, 1)), _
                                  .Offset(getY(t.ID, t.Z, t.Y, 2), getX(t.ID, t.Z, t.X, 2)), _
                                  .Offset(getY(t.ID, t.Z, t.Y, 3), getX(t.ID, t.Z, t.X, 3)), _
                                  .Offset(getY(t.ID, t.Z, t.Y, 4), getX(t.ID, t.Z, t.X, 4)))
    End With
End Function

'https://codeincomplete.com/posts/javascript-tetris/
Private Function getTetromino() As Tetromino
    Randomize
    getTetromino.ID = Int(Rnd * 7) + 1
End Function

Private Function getX(ByVal ID As Long, ByVal Z As Long, ByVal X As Long, ByVal Index As Long) As Long
    Dim Data As Variant: Data = Array(1, 1, 1, 1, 0, 1, 2, 3, 2, 2, 2, 2, 0, 1, 2, 3, 1, 1, 0, 1, 0, 0, 1, 2, 1, 2, 1, 1, 0, 1, 2, 2, 1, 1, 1, 2, 0, 1, 2, 0, 0, 1, 1, 1, 2, 0, 1, 2, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 1, 2, 0, 1, 0, 0, 1, 1, 1, 2, 0, 1, 1, 1, 2, 2, 0, 1, 2, 1, 1, 0, 1, 1, 1, 0, 1, 2, 1, 1, 2, 1, 0, 1, 1, 2, 1, 0, 1, 0, 0, 1, 1, 2, 2, 1, 2, 1)
    getX = Data((ID - 1) * 16 + Z * 4 + Index - 1) + X
End Function

Private Function getY(ByVal ID As Long, ByVal Z As Long, ByVal Y As Long, ByVal Index As Long) As Long
    Dim Data As Variant: Data = Array(0, 1, 2, 3, 1, 1, 1, 1, 0, 1, 2, 3, 2, 2, 2, 2, 0, 1, 2, 2, 0, 1, 1, 1, 0, 0, 1, 2, 1, 1, 1, 2, 0, 1, 2, 2, 1, 1, 1, 2, 0, 0, 1, 2, 0, 1, 1, 1, 0, 0, 1, 1, 0, 0, 1, 1, 0, 0, 1, 1, 0, 0, 1, 1, 1, 1, 2, 2, 0, 1, 1, 2, 0, 0, 1, 1, 0, 1, 1, 2, 1, 1, 1, 2, 0, 1, 1, 2, 0, 1, 1, 1, 0, 1, 1, 2, 1, 1, 2, 2, 0, 1, 1, 2, 0, 0, 1, 1, 0, 1, 1, 2)
    getY = Data((ID - 1) * 16 + Z * 4 + Index - 1) + Y
End Function

Private Sub InsertScores(ByRef p As Player)
    Dim SQL As String
    Dim Conn As Object, rs As Object
    Set Conn = CreateObject("ADODB.Connection")
    Conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    Conn.Open
    SQL = "INSERT INTO [High Scores$]([Names],[Scores],[Lines],[Level],[Date-Time]) VALUES(" & _
          "'" & p.NameRange.Value & "'," & p.ScoreRange.Value & "," & p.ScoreLines.Value & "," & p.LevelRange.Value & ",#" & Now & "#);"
    Conn.Execute SQL
    Conn.Close
    sbSortTable
End Sub

Private Function isValidIndex(ByRef p As Player, ByVal Index As Long)
    Dim X As Long, Y As Long
    With p.NextTetromino
        X = getX(.ID, .Z, .X, Index)
        Y = getY(.ID, .Z, .Y, Index)
        If Y >= 0 And Y <= GRID_HEIGHT And X >= 0 And X <= GRID_WIDTH Then
            If p.Grid(Y, X) = 0 Then isValidIndex = True
        End If
    End With
End Function

Private Function isValidMove(ByRef p As Player) As Boolean
    isValidMove = isValidIndex(p, 1) And isValidIndex(p, 2) And isValidIndex(p, 3) And isValidIndex(p, 4)
End Function

Private Sub MoveTetromino(ByRef p As Player)
    p.CurrTetromino = p.NextTetromino
End Sub

Sub sbSortTable()
    With wsHighScores
        .UsedRange.Value = .UsedRange.Value           'Convert Numbers Stored as Strings to Numbers
        .Range("A1:E1", .Range("A" & Rows.Count).End(xlUp)).Sort .Range("A2"), xlAscending, Header:=xlYes
        .Range("A1:E1", .Range("A" & Rows.Count).End(xlUp)).Sort .Range("B2"), xlDescending, Header:=xlYes
    End With
End Sub

Public Sub setGameState(ByVal AppState As GameState)
    AppGameState = AppState
    setSheetView Maximize:=AppGameState = gsRunning
End Sub

Private Sub setPlayerDefaultRanges(ByRef p As Player, ByRef Target As Range, ByVal Y As Long, ByVal Caption As String, ByVal Value As Variant)
    Set Target = p.PreviewRange.Offset(Y).Cells(1, 1)
    Target.Resize(1, 4).Style = STYLE_PREFIX & 0
    Target.Resize(1, 4).HorizontalAlignment = xlCenterAcrossSelection
    Target.Value = Value
    Target.Offset(-1).Value = Caption
    Target.Offset(-1).Resize(1, 4).HorizontalAlignment = xlCenterAcrossSelection
End Sub

Public Sub setSheetView(Optional ByVal Maximize As Boolean)
    With wsTetris
        .Activate
        If Maximize Then
            .Protect UserInterfaceOnly:=True          ', DrawingObjects:=True, Contents:=True, Scenarios:=True
            .EnableSelection = xlNoSelection
            .ScrollArea = "A1"
        Else
            .ScrollArea = ""
            .Unprotect
        End If
    End With

    With Application
        .Cursor = IIf(Maximize, xlIBeam, xlDefault)
        .DisplayFullScreen = Maximize
        .DisplayFormulaBar = Not Maximize
        .DisplayAlerts = Not Maximize
        If Not Maximize Then .ScreenUpdating = True
    End With

    With ActiveWindow
        .DisplayHeadings = Not Maximize
        .DisplayGridlines = Not Maximize
        .DisplayWorkbookTabs = Not Maximize
        If Not Maximize Then ActiveWindow.Zoom = 100
    End With
End Sub

Private Sub SetTetromino(ByRef p As Player)
    Dim n As Long, Y As Long
    With p.CurrTetromino
        For n = 1 To 4
            Y = getY(.ID, .Z, .Y, n)
            p.Grid(Y, getX(.ID, .Z, .X, n)) = .ID
            If Y < 2 Then MsgBox "Game Over"
        Next
    End With
End Sub

Public Sub StartGame()
    Const Level = 1
    Static LastTime!, Players() As Player, Ticks As Long
    Dim t As Tetromino
    Dim n As Long

    If AppGameState = gsNewGame Then
        Application.ScreenUpdating = False
        Ticks = 0
        ClearTetris
        AddPlayers Players
        Application.Goto wsTetris.Cells(1, 1), True
        Range(wsTetris.Cells(1, 1), Players(UBound(Players)).GameRange.Resize(26, 15)).Select
        ActiveWindow.Zoom = True
        wsTetris.Cells(1, 1).Select
        Application.ScreenUpdating = True
        setGameState gsRunning
    End If

    Do
        Ticks = Ticks + 1

        If GetAsyncKeyState(vbKeyEnd) Then setGameState gsPaused

        If AppGameState = gsRunning Then
            If Ticks Mod 2000 = 0 Then
                For n = 0 To UBound(Players)
                    CheckKeys Players(n)
                    Players(n).Ticks = Players(n).Ticks + 1
                Next
            End If

            If Ticks Mod 4000 = 0 Then
                For n = 0 To UBound(Players)
                    If (Players(n).Ticks + Players(n).Speed) > 10 Then
                        Players(n).Ticks = 0
                        AutoMoveTetromino Players(n)
                    End If
                    DrawBoard Players(n)
                    ConsolidateGrid Players(n)
                Next
            End If
        ElseIf AppGameState = gsGameOver Then
            GameOver Players
            wsTetris.tglPauseGame.Caption = "Pause"
            wsTetris.tglPauseGame.Value = False
            setSheetView False
            End
        End If

        DoEvents
    Loop
End Sub

Let me know if you have any ideas on how to better even out the performance.

How does excel take in four different inputs? Does it cycle through players? — Raystafarian, Feb 2, 2018 at 4:18
Yes, the players are loaded from a SQL call into an Array called `Players'. The arrray is cycled through 2000 cycles. — user109261, Feb 2, 2018 at 5:10
No, the Players array contains key code information for each Players' movement keys. The Game loop checks the GetAsyncKeyState of each Players movement key. If one of the keys are pressed then the corresponding move for the current Tetromino will be validated and subsequently moved; if passes the validation. — user109261, Feb 3, 2018 at 9:53
Forgive me if this is clear in the question, but why can't you use a timer, instead of the count of loops? Does that interfere with the ASyncKeyState? — Raystafarian, Mar 4, 2018 at 23:23

Raystafarian · Accepted Answer · 2018-03-15 22:27:46Z

Not knowing exactly how your movement scheme operates, you could use a timer sort of like -

Const TIME_ITERATION_VALUE As String = "00:00:02"
Public timerActive As Boolean
Sub Timing()
    Start_Timing
    Dim repeatInterval As Date
    If timerActive Then
        If GetAsyncKeyState(vbKeyEnd) Then setGameState gsPaused
        If AppGameState = gsRunning Then
            'do your moving, check for auto-movement
        End If
    ElseIf AppGameState = gsGameOver Then
        GameOver Players
        wsTetris.tglPauseGame.Caption = "Pause"
        wsTetris.tglPauseGame.Value = False
        setSheetView False
    End If
    repeatInterval = Now + TimeValue(TIME_ITERATION_VALUE)
    Application.OnTime repeatInterval, "Timing"
End Sub
Public Sub Start_Timing()
    timerActive = True
    Application.OnTime Now + TimeValue(TIME_ITERATION_VALUE), "Timing"
End Sub

Public Sub Stop_Timing()
    timerActive = False
End Sub

At least, that's how I implemented it in Snake.

Stack Exchange Network

Excel VBA Multiplayer Tetris Game Loop Repaint Rate

Ticks per second

Single Player

4 Players

Game Loop

wsTetris: Worksheet Module

1 Answer 1

Your Answer

Hot Network Questions

Excel VBA Multiplayer Tetris Game Loop Repaint Rate

Ticks per second

Single Player

4 Players

Game Loop

wsTetris: Worksheet Module

1 Answer 1

Your Answer

Sign up or log in

Post as a guest

Related

Hot Network Questions