VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CellDisplayDriver"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
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