Excel VBA Multiplayer Tetris Game Loop Repaint Rate

Question 1

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

enter image description here

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

Tetris Demo Gif

4 Players

enter image description here

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.

Question 2

How does excel take in four different inputs? Does it cycle through players?

Question 3

Yes, the players are loaded from a SQL call into an Array called `Players'. The arrray is cycled through 2000 cycles.

Question 4

So the moves are already determined? It's not live play

Question 5

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.

Question 6

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?

Question 7

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.

Raystafarian Raystafarian 7,2991 gold badge23 silver badges60 bronze badges · 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

Sign up or log in

Post as a guest

Post as a guest

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

Post as a guest

Related

Hot Network Questions