Excel display driver class for Tetris

Question

This is the first of (hopefully) several posts as I reimplement an ancient (and unfortunately long lost) Excel VBA Tetris clone. The main workhorse class in the game engine is the display driver, which uses a rectangular area of a Worksheet to emulate a monitor. The display is sprite based, so the class holds a Dictionary loaded with IDrawables, which are basically bitmaps. The interface is as follows:

'IDrawable.cls
Option Explicit

Public Property Get Top() As Long
End Property

Public Property Let Top(inValue As Long)
End Property

Public Property Get Left() As Long
End Property

Public Property Let Left(inValue As Long)
End Property

Public Property Get Width() As Long
End Property

Public Property Get Height() As Long
End Property

Public Property Let Bitmap(colors() As Long)
End Property

Public Property Get Bitmap() As Long()
End Property

Public Function GetPixel(pixelRow As Long, pixelColumn As Long) As Long
End Function

---

Properties

AnchorCell - This is a one cell Range that determines where the display rectangle will be placed. It will raise an error if more than one cell is passed.

Top and Left are the row and column number of the AnchorCell in the parent Worksheet's coordinates. These are read-only and are derived from the AnchorCell.

Width and Height set the dimensions of the display.

DotPitch is the size of each "pixel", and the rows and columns in the display range are set to this width and height (in pixels). Currently I have it limited to CGA resolution (mainly for convenience when I test it), but the limits can be set by altering the appropriate constants.

BackColor sets the background color for the display. Any pixel in an IDrawable that matches the BackColor will be "transparent".

---

Methods

AddDrawable, RemoveDrawable and ClearDrawables are the main methods for interacting with the display. Any item added to the container will be rendered.

Refresh forces the display to repaint itself. If changes were made to any of the properties that alter how it is rendered on the Worksheet, it will apply those changes. As a side note, this should eventually include Z-ordering, but I'm still up in the air as to the implementation details (and Tetris doesn't need the functionality - maybe for some other game...). There's also room for improvement in the resize - I currently have the conversion between character width and pixels fixed, but it should really calculate it based on the display settings.

Create is simply a factory method. I'm open to ideas as to how to make the "default constructor" private. :-P

---

The Code

Note, VB_PredeclaredId is set to True. For convenience, the raw file is available on pastebin.

^{Yes, yes, I know - I'll get it up on github eventually.}

'CellDisplayDriver.cls
Option Explicit

Public Enum DriverErrors
    NullRangeError = vbObjectError + 1
    ArgumentError = vbObjectError + 2
    InvalidStateError = vbObjectError + 3
End Enum

Private Const MIN_WIDTH As Long = 10
Private Const MAX_WIDTH As Long = 160
Private Const MIN_HEIGHT As Long = 10
Private Const MAX_HEIGHT As Long = 100
Private Const MIN_PITCH As Long = 1
Private Const MAX_PITCH As Long = 10

Private Type DriverProperties
    AnchorCell As Range
    Top As Long
    Left As Long
    Width As Long
    Height As Long
    DotPitch As Long
    BackColor As Long
    DisplayArea As Range
    Drawables As Scripting.Dictionary
    PendingResize As Boolean
End Type

Private this As DriverProperties

Private Sub Class_Initialize()
    With this
        Set .Drawables = New Scripting.Dictionary
        .PendingResize = True
        .Width = MIN_WIDTH
        .Height = MIN_HEIGHT
        .DotPitch = MAX_PITCH
    End With
End Sub

Public Property Get AnchorCell() As Range
    Set AnchorCell = this.AnchorCell
End Property

Public Property Set AnchorCell(inValue As Range)
    If inValue Is Nothing Then
        Err.Raise DriverErrors.NullRangeError, "CellDisplayDriver.AnchorCell", "AnchorCell cannot be set to Nothing."
    End If

    With inValue
        If .Rows.Count > 1 Or .Columns.Count > 1 Then
            RaiseInvalidArgument "AnchorCell", "AnchorCell must be a Range containing a single cell."
        End If
    End With

    If Not this.AnchorCell Is Nothing Then
        this.PendingResize = inValue.Address <> this.AnchorCell.Address
    End If

    Set this.AnchorCell = inValue
    With this.AnchorCell
        this.Top = .Rows(1).Row
        this.Left = .Columns(1).Column
    End With

    With this.AnchorCell.Parent
        Set this.DisplayArea = .Range(.Cells(this.Top, this.Left), _
                               .Cells(this.Top + this.Height - 1, this.Left + this.Width - 1))
    End With
End Property

Public Property Get Top() As Long
    Top = this.Top
End Property

Public Property Get Left() As Long
    Left = this.Left
End Property

Public Property Get Width() As Long
    Width = this.Width
End Property

Public Property Let Width(inValue As Long)
    If inValue < MIN_WIDTH Or inValue > MAX_WIDTH Then
        RaiseInvalidArgument "Width", "Width must be between " & MIN_WIDTH & " and " & MAX_WIDTH & "."
    End If
    this.PendingResize = inValue <> this.Width
    this.Width = inValue
End Property

Public Property Get Height() As Long
    Height = this.Height
End Property

Public Property Let Height(inValue As Long)
    If inValue < MIN_HEIGHT Or inValue > MAX_HEIGHT Then
        RaiseInvalidArgument "Height", "Height must be between " & MIN_HEIGHT & " and " & MAX_HEIGHT & "."
    End If
    this.PendingResize = inValue <> this.Height
    this.Height = inValue
End Property

Public Property Get DotPitch() As Long
    DotPitch = this.DotPitch
End Property

Public Property Let DotPitch(inValue As Long)
    If inValue < MIN_PITCH Or inValue > MAX_PITCH Then
        RaiseInvalidArgument "Create", "Dot pitch must be between " & MIN_PITCH & " and " & MAX_PITCH & "."
    End If
    this.PendingResize = inValue <> this.DotPitch
    this.DotPitch = inValue
End Property

Public Property Get BackColor() As Long
    BackColor = this.BackColor
End Property

Public Property Let BackColor(rgbValue As Long)
    this.BackColor = rgbValue
End Property

Public Sub AddDrawable(addition As IDrawable)
    With this.Drawables
        If Not .Exists(addition) Then .Add addition, vbNull
    End With
End Sub

Public Sub RemoveDrawable(deletion As IDrawable)
    With this.Drawables
        If .Exists(deletion) Then .Remove deletion
    End With
End Sub

Public Sub ClearDrawables()
    this.Drawables.RemoveAll
End Sub

Public Sub Refresh()
    If this.DisplayArea Is Nothing Then
        Err.Raise DriverErrors.InvalidStateError, "CellDisplayDriver.Refresh", "AnchorCell must be set prior to Refresh."
    End If

    Application.ScreenUpdating = False
    If this.PendingResize Then Resize

    With this.DisplayArea
        .Interior.Color = this.BackColor
        Dim drawable As Variant
        For Each drawable In this.Drawables.Keys
            Dim r As Long
            Dim c As Long
            Dim rowTarget As Long
            Dim colTarget As Long
            For r = 1 To drawable.Height
                rowTarget = r + drawable.Top
                If rowTarget >= 1 And rowTarget < this.Height Then
                    For c = 1 To drawable.Width
                        colTarget = c + drawable.Left
                        If colTarget >= 1 And colTarget < this.Width Then
                            .Cells(rowTarget, colTarget).Interior.Color = drawable.GetPixel(r, c)
                        End If
                    Next
                End If
            Next
        Next
    End With
    Application.ScreenUpdating = True
    DoEvents
End Sub

Public Function Create(displayWidth As Long, displayHeight As Long, pitch As Long, anchor As Range) As CellDisplayDriver
    Dim display As New CellDisplayDriver
    With display
        .Width = displayWidth
        .Height = displayHeight
        .DotPitch = pitch
        Set .AnchorCell = anchor
    End With
    Set Create = display
End Function

Private Sub Resize()
    With this.DisplayArea
        Dim rng As Range
        For Each rng In .Cells.Rows
            rng.RowHeight = this.DotPitch
        Next
        For Each rng In .Cells.Columns
            rng.ColumnWidth = this.DotPitch * 0.085
        Next
        .Interior.Color = this.BackColor
    End With

    this.PendingResize = False
End Sub

Private Sub RaiseInvalidArgument(proc As String, description As String)
    Err.Raise DriverErrors.ArgumentError, "CellDisplayDriver." & proc, description
End Sub

---

Test code

This isn't nearly as much fun without some test code, so I knocked together a super basic IDrawable...

'Sprite.cls
Option Explicit
Implements IDrawable

Private Type SpriteMembers
    Top As Long
    Left As Long
    Bitmap() As Long
End Type

Private this As SpriteMembers

Public Property Get Top() As Long
    Top = this.Top
End Property

Public Property Let Top(inValue As Long)
    this.Top = inValue
End Property

Public Property Get Left() As Long
    Left = this.Left
End Property

Public Property Let Left(inValue As Long)
    this.Left = inValue
End Property

Public Property Get Width() As Long
    Width = UBound(this.Bitmap, 2) + 1
End Property

Public Property Get Height() As Long
    Height = UBound(this.Bitmap, 1) + 1
End Property

Public Property Let Bitmap(colors() As Long)
    this.Bitmap = colors
End Property

Public Property Get Bitmap() As Long()
    Bitmap = this.Bitmap
End Property

Public Function GetPixel(pixelRow As Long, pixelColumn As Long) As Long
    GetPixel = this.Bitmap(pixelRow - 1, pixelColumn - 1)
End Function

Public Property Get IDrawable_Top() As Long
    IDrawable_Top = Top
End Property

Public Property Let IDrawable_Top(inValue As Long)
    Top = inValue
End Property

Public Property Get IDrawable_Left() As Long
    IDrawable_Left = Left
End Property

Public Property Let IDrawable_Left(inValue As Long)
    Left = inValue
End Property

Public Property Get IDrawable_Width() As Long
    IDrawable_Width = Width
End Property

Public Property Get IDrawable_Height() As Long
    IDrawable_Height = Height
End Property

Public Property Let IDrawable_BitMap(colors() As Long)
    Bitmap = colors
End Property

Public Property Get IDrawable_BitMap() As Long()
    IDrawable_BitMap = Bitmap
End Property

Public Function IDrawable_GetPixel(pixelRow As Long, pixelColumn As Long) As Long
    IDrawable_GetPixel = GetPixel(pixelRow, pixelColumn)
End Function

...and a test Sub that bounces a red square around:

Sub Test()
    Dim sheet As Worksheet
    Set sheet = ActiveWorkbook.Worksheets.Add
    sheet.Name = "Demo"

    Dim screen As CellDisplayDriver
    Set screen = CellDisplayDriver.Create(160, 100, 2, ActiveSheet.Cells(2, 2))
    Dim foo As Sprite
    Set foo = New Sprite

    Dim colors() As Long
    ReDim colors(9, 9)
    Dim r As Long
    Dim c As Long
    For r = 0 To 9
        For c = 0 To 9
            colors(r, c) = RGB(255, 0, 0)
        Next
    Next

    With foo
        .Top = 45
        .Left = 0
        .Bitmap = colors
    End With

    Dim down As Boolean
    Dim right As Boolean
    Dim frames As Long

    screen.AddDrawable foo
    Dim ending As Single
    ending = Timer + 30
    With foo
        Do
            If .Left = 0 Then right = True
            If .Left = 150 Then right = False
            If .Top = 0 Then down = True
            If .Top = 90 Then down = False
            If right Then
                .Left = .Left + 1
            Else
                .Left = .Left - 1
            End If
            If down Then
                .Top = .Top + 1
            Else
                .Top = .Top - 1
            End If
            screen.Refresh
            frames = frames + 1
        Loop While Timer < ending
    End With

    Application.DisplayAlerts = False
    sheet.Delete
    Application.DisplayAlerts = True
    Debug.Print "~" & Format$(frames / 30, "#.00") & " frames per second."
End Sub

---

Edit:

Sample "output" by popular request:

Answer 1

First let me say that this is pure awesome, and I only have superficial improvements to suggest. nevermind, this grew bigger than I originally thought.... again.

There is no reason for any of the parameters (well, except the array one) you're passing any of the IDrawable interface members to be passed ByRef - and they're all passed by reference, implicitly.

Public Property Let Top(inValue As Long)
End Property

Public Property Let Left(inValue As Long)
End Property

Public Function GetPixel(pixelRow As Long, pixelColumn As Long) As Long
End Function

Could be:

Public Property Let Top(ByVal inValue As Long)
End Property

Public Property Let Left(ByVal inValue As Long)
End Property

Public Function GetPixel(ByVal pixelRow As Long, ByVal pixelColumn As Long) As Long
End Function

While we're at it, might as well make the colors() array explicitly passed ByRef:

Public Property Let Bitmap(ByRef colors() As Long)
End Property

In the Sprite class (I know, it's test/demo code), there's not really a need to expose any public members - in fact the only reason you do need them is because you've declared foo As Sprite:

Dim foo As Sprite
Set foo = New Sprite

But this would work just as well:

Dim foo As IDrawable
Set foo = New Sprite

Actually, I think the IDrawable interface should not expose Property Let members to mutate Top and Left values (but leave them on the concrete implementations... or don't - and give it a PredeclaredId and a Create function instead). It could expose some Move procedure instead of mutators:

Public Sub Move(ByVal x As Long, ByVal y As Long)
End Sub

That would change this client code:

If right Then
    .Left = .Left + 1
Else
    .Left = .Left - 1
End If
If down Then
    .Top = .Top + 1
Else
    .Top = .Top - 1
End If

Into that one-liner:

.Move IIf(right, 1, -1), IIf(down, 1, -1)

---

The Refresh method feels a bit cluttered, because it's responsible for drawing every pixel of every drawable object. You could have some DrawableObject with a PredeclaredId, and a "static" method where you could draw one single IDrawable object:

Public Sub Draw(ByRef drawable As IDrawable, ByRef screen As Range)
    Dim r As Long
    Dim c As Long
    Dim rowTarget As Long
    Dim colTarget As Long
    For r = 1 To drawable.Height
        rowTarget = r + drawable.Top
        If rowTarget >= 1 And rowTarget < this.Height Then
            For c = 1 To drawable.Width
                colTarget = c + drawable.Left
                If colTarget >= 1 And colTarget < this.Width Then
                    screen.Cells(rowTarget, colTarget).Interior.Color = drawable.GetPixel(r, c)
                End If
            Next
        End If
    Next
End Sub

Then this:

With this.DisplayArea
    .Interior.Color = this.BackColor
    Dim drawable As Variant
    For Each drawable In this.Drawables.Keys
        Dim r As Long
        Dim c As Long
        Dim rowTarget As Long
        Dim colTarget As Long
        For r = 1 To drawable.Height
            rowTarget = r + drawable.Top
            If rowTarget >= 1 And rowTarget < this.Height Then
                For c = 1 To drawable.Width
                    colTarget = c + drawable.Left
                    If colTarget >= 1 And colTarget < this.Width Then
                        .Cells(rowTarget, colTarget).Interior.Color = drawable.GetPixel(r, c)
                    End If
                Next
            End If
        Next
    Next
End With

Becomes this:

With this.DisplayArea
    .Interior.Color = this.BackColor
    Dim drawable As Variant 'shame this can't be IDrawable.. right?
    For Each drawable In this.Drawables.Keys
        DrawableObject.Draw drawable, .Range 'might need to cast to IDrawable
    Next
End With

Answer 2

Have you considered using Conditional Formats as your rendering cathode ray?

I've just thrown this together, so it's by no means complete or optimized, but by assigning sprite arrays of values to specific ranges, I avoid the need for any calls to the interior of a Range. This approach might also solve your Z-Order dilemma, as you can just write over the top, or you could even to blends!

It's fast. So fast I can't tell if it's even rendering on every frame, but I do see lots of movement. It runs about twice as fast if I omit the removal of the prior sprite location.

Theoretically, it's 1500 frames/sec with sprite erase on each frame, or 4000 frames/sec if I omit the sprite erase on each frame.

Set up the screen Apply 3 different conditional formats for values 1, 2 and 3

Sub InitScreen()
    Dim screen As Range
    Set screen = Range(Cells(1, 1), Cells(ScreenHeight, ScreenWidth))
    screen.EntireColumn.ColumnWidth = 0.15
    screen.EntireRow.RowHeight = 2
    screen.FormatConditions.Delete
    With screen.FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, Formula1:="=1")
      .SetFirstPriority
      .Interior.Color = RGB(192, 32, 32)
    End With
    With screen.FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, Formula1:="=2")
      .SetFirstPriority
      .Interior.Color = RGB(32, 192, 32)
    End With
    With screen.FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, Formula1:="=3")
      .SetFirstPriority
      .Interior.Color = RGB(32, 32, 192)
    End With
End Sub

Render the Frames Define a sprite of random numbers between 1 and 3, and a sprite the same size of all zeros.

Sub RenderFrames()
  Const FrameCount As Long = 1500
  Const SpriteHeight As Long = 3
  Const SpriteWidth As Long = 3

  Dim screen As Range
  Dim i As Long, j As Long, x As Long
  Dim sprite(1 To 3, 1 To 3)
  Dim spriteLocation As Range
  Dim start As Double

  Set screen = Range(Cells(1, 1), Cells(ScreenHeight, ScreenWidth))

  'Set up an sprite
  Dim eraserSprite(1 To 3, 1 To 3) As Long

  'Set up a random sprite
  For i = 1 To SpriteHeight
    For j = 1 To SpriteWidth
      sprite(i, j) = 1 + (Rnd * 17 Mod 3)
    Next j
  Next i

  start = Timer
  For x = 1 To FrameCount
    If Not spriteLocation Is Nothing Then
      spriteLocation.Value2 = eraserSprite
    End If
    Set spriteLocation = screen.Range(Cells(1 + x Mod 150, 1), Cells(4 + x Mod 150, 3))
    spriteLocation.Value2 = sprite
  Next x
  Debug.Print Timer - start, FrameCount / (Timer - start)
End Sub