# Excel VBA Multiplayer Tetris Game Loop Repaint Rate

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

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

## 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
If Not Maximize Then .ScreenUpdating = True
End With

With ActiveWindow
.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
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? 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
• So the moves are already determined? It's not live play Feb 3, 2018 at 2:59
• 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? Mar 4, 2018 at 23:23

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.