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
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.
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
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".
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
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
This isn't nearly as much fun without some test code, so I knocked together a super basic
'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
Sample "output" by popular request: