SHARE
TWEET

Untitled

a guest Sep 14th, 2016 70 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "CellDisplayDriver"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = False
  8. Attribute VB_PredeclaredId = True
  9. Attribute VB_Exposed = False
  10. Option Explicit
  11.  
  12. Public Enum DriverErrors
  13.     NullRangeError = vbObjectError + 1
  14.     ArgumentError = vbObjectError + 2
  15.     InvalidStateError = vbObjectError + 3
  16. End Enum
  17.  
  18. Private Const MIN_WIDTH As Long = 10
  19. Private Const MAX_WIDTH As Long = 160
  20. Private Const MIN_HEIGHT As Long = 10
  21. Private Const MAX_HEIGHT As Long = 100
  22. Private Const MIN_PITCH As Long = 1
  23. Private Const MAX_PITCH As Long = 10
  24.  
  25. Private Type DriverProperties
  26.     AnchorCell As Range
  27.     Top As Long
  28.     Left As Long
  29.     Width As Long
  30.     Height As Long
  31.     DotPitch As Long
  32.     BackColor As Long
  33.     DisplayArea As Range
  34.     Drawables As Scripting.Dictionary
  35.     PendingResize As Boolean
  36. End Type
  37.  
  38. Private this As DriverProperties
  39.  
  40. Private Sub Class_Initialize()
  41.     With this
  42.         Set .Drawables = New Scripting.Dictionary
  43.         .PendingResize = True
  44.         .Width = MIN_WIDTH
  45.         .Height = MIN_HEIGHT
  46.         .DotPitch = MAX_PITCH
  47.     End With
  48. End Sub
  49.  
  50. Public Property Get AnchorCell() As Range
  51.     Set AnchorCell = this.AnchorCell
  52. End Property
  53.  
  54. Public Property Set AnchorCell(inValue As Range)
  55.     If inValue Is Nothing Then
  56.         Err.Raise DriverErrors.NullRangeError, "CellDisplayDriver.AnchorCell", "AnchorCell cannot be set to Nothing."
  57.     End If
  58.  
  59.     With inValue
  60.         If .Rows.Count > 1 Or .Columns.Count > 1 Then
  61.             RaiseInvalidArgument "AnchorCell", "AnchorCell must be a Range containing a single cell."
  62.         End If
  63.     End With
  64.        
  65.     If Not this.AnchorCell Is Nothing Then
  66.         this.PendingResize = inValue.Address <> this.AnchorCell.Address
  67.     End If
  68.    
  69.     Set this.AnchorCell = inValue
  70.     With this.AnchorCell
  71.         this.Top = .Rows(1).Row
  72.         this.Left = .Columns(1).Column
  73.     End With
  74.  
  75.     With this.AnchorCell.Parent
  76.         Set this.DisplayArea = .Range(.Cells(this.Top, this.Left), _
  77.                                .Cells(this.Top + this.Height - 1, this.Left + this.Width - 1))
  78.     End With
  79. End Property
  80.  
  81. Public Property Get Top() As Long
  82.     Top = this.Top
  83. End Property
  84.  
  85. Public Property Get Left() As Long
  86.     Left = this.Left
  87. End Property
  88.  
  89. Public Property Get Width() As Long
  90.     Width = this.Width
  91. End Property
  92.  
  93. Public Property Let Width(inValue As Long)
  94.     If inValue < MIN_WIDTH Or inValue > MAX_WIDTH Then
  95.         RaiseInvalidArgument "Width", "Width must be between " & MIN_WIDTH & " and " & MAX_WIDTH & "."
  96.     End If
  97.     this.PendingResize = inValue <> this.Width
  98.     this.Width = inValue
  99. End Property
  100.  
  101. Public Property Get Height() As Long
  102.     Height = this.Height
  103. End Property
  104.  
  105. Public Property Let Height(inValue As Long)
  106.     If inValue < MIN_HEIGHT Or inValue > MAX_HEIGHT Then
  107.         RaiseInvalidArgument "Height", "Height must be between " & MIN_HEIGHT & " and " & MAX_HEIGHT & "."
  108.     End If
  109.     this.PendingResize = inValue <> this.Height
  110.     this.Height = inValue
  111. End Property
  112.  
  113. Public Property Get DotPitch() As Long
  114.     DotPitch = this.DotPitch
  115. End Property
  116.  
  117. Public Property Let DotPitch(inValue As Long)
  118.     If inValue < MIN_PITCH Or inValue > MAX_PITCH Then
  119.         RaiseInvalidArgument "Create", "Dot pitch must be between " & MIN_PITCH & " and " & MAX_PITCH & "."
  120.     End If
  121.     this.PendingResize = inValue <> this.DotPitch
  122.     this.DotPitch = inValue
  123. End Property
  124.  
  125. Public Property Get BackColor() As Long
  126.     BackColor = this.BackColor
  127. End Property
  128.  
  129. Public Property Let BackColor(rgbValue As Long)
  130.     this.BackColor = rgbValue
  131. End Property
  132.  
  133. Public Sub AddDrawable(addition As IDrawable)
  134.     With this.Drawables
  135.         If Not .Exists(addition) Then .Add addition, vbNull
  136.     End With
  137. End Sub
  138.  
  139. Public Sub RemoveDrawable(deletion As IDrawable)
  140.     With this.Drawables
  141.         If .Exists(deletion) Then .Remove deletion
  142.     End With
  143. End Sub
  144.  
  145. Public Sub ClearDrawables()
  146.     this.Drawables.RemoveAll
  147. End Sub
  148.  
  149. Public Sub Refresh()
  150.     If this.DisplayArea Is Nothing Then
  151.         Err.Raise DriverErrors.InvalidStateError, "CellDisplayDriver.Refresh", "AnchorCell must be set prior to Refresh."
  152.     End If
  153.  
  154.     Application.ScreenUpdating = False
  155.     If this.PendingResize Then Resize
  156.    
  157.     With this.DisplayArea
  158.         .Interior.Color = this.BackColor
  159.         Dim drawable As Variant
  160.         For Each drawable In this.Drawables.Keys
  161.             Dim r As Long
  162.             Dim c As Long
  163.             Dim rowTarget As Long
  164.             Dim colTarget As Long
  165.             For r = 1 To drawable.Height
  166.                 rowTarget = r + drawable.Top
  167.                 If rowTarget >= 1 And rowTarget < this.Height Then
  168.                     For c = 1 To drawable.Width
  169.                         colTarget = c + drawable.Left
  170.                         If colTarget >= 1 And colTarget < this.Width Then
  171.                             .Cells(rowTarget, colTarget).Interior.Color = drawable.GetPixel(r, c)
  172.                         End If
  173.                     Next
  174.                 End If
  175.             Next
  176.         Next
  177.     End With
  178.     Application.ScreenUpdating = True
  179.     DoEvents
  180. End Sub
  181.  
  182. Public Function Create(displayWidth As Long, displayHeight As Long, pitch As Long, anchor As Range) As CellDisplayDriver
  183.     Dim display As New CellDisplayDriver
  184.     With display
  185.         .Width = displayWidth
  186.         .Height = displayHeight
  187.         .DotPitch = pitch
  188.         Set .AnchorCell = anchor
  189.     End With
  190.     Set Create = display
  191. End Function
  192.  
  193. Private Sub Resize()
  194.     With this.DisplayArea
  195.         Dim rng As Range
  196.         For Each rng In .Cells.Rows
  197.             rng.RowHeight = this.DotPitch
  198.         Next
  199.         For Each rng In .Cells.Columns
  200.             rng.ColumnWidth = this.DotPitch * 0.085
  201.         Next
  202.         .Interior.Color = this.BackColor
  203.     End With
  204.    
  205.     this.PendingResize = False
  206. End Sub
  207.  
  208. Private Sub RaiseInvalidArgument(proc As String, description As String)
  209.     Err.Raise DriverErrors.ArgumentError, "CellDisplayDriver." & proc, description
  210. End Sub
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top