vbAccelerator - Contents of code file: cDrawSample.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cDrawSample"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Type POINTAPI
   x As Long
   y As Long
End Type
Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal xOffset
 As Long, ByVal yOffset As Long) As Long
Private Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long)
 As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long)
 As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal
 nWidth As Long, ByVal crColor As Long) As Long
Private Const PS_SOLID = 0
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As
 Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal
 wFormat As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal
 hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
 Long
Private Enum EDrawTextFormat
   DT_BOTTOM = &H8
   DT_CALCRECT = &H400
   DT_CENTER = &H1
   DT_EXPANDTABS = &H40
   DT_EXTERNALLEADING = &H200
   DT_INTERNAL = &H1000
   DT_LEFT = &H0
   DT_NOCLIP = &H100
   DT_NOPREFIX = &H800
   DT_RIGHT = &H2
   DT_SINGLELINE = &H20
   DT_TABSTOP = &H80
   DT_TOP = &H0
   DT_VCENTER = &H4
   DT_WORDBREAK = &H10
   DT_EDITCONTROL = &H2000&
   DT_PATH_ELLIPSIS = &H4000&
   DT_END_ELLIPSIS = &H8000&
   DT_MODIFYSTRING = &H10000
   DT_RTLREADING = &H20000
   DT_WORD_ELLIPSIS = &H40000
End Enum
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal
 nBkMode As Long) As Long
Private Const OPAQUE = 2
Private Const TRANSPARENT = 1
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal
 crColor As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private Type DrawObjectData
   iDirX As Integer
   iDirY As Integer
   foreColor As Long
   backColor As Long
   sCaption As String
   tP As POINTAPI
   lSize As Long
End Type
Private m_tDrawObject() As DrawObjectData
Private m_iDrawObjectCount As Long
Private m_font As IFont

Private m_bUseMemDc As Boolean
Private m_cMemDc As pcMemDC
Private m_tR As RECT


Public Property Get UseMemDc() As Boolean
   UseMemDc = m_bUseMemDc
End Property
Public Property Let UseMemDc(ByVal value As Boolean)
   m_bUseMemDc = value
End Property
Public Property Get Left() As Long
   Left = m_tR.Left
End Property
Public Property Let Left(ByVal value As Long)
   m_tR.Left = value
End Property
Public Property Get Top() As Long
   Top = m_tR.Top
End Property
Public Property Let Top(ByVal value As Long)
   m_tR.Top = value
End Property
Public Property Get Width() As Long
   Width = m_cMemDc.Width
End Property
Public Property Let Width(ByVal value As Long)
   m_cMemDc.Width = value
End Property
Public Property Get Height() As Long
   Height = m_cMemDc.Height
End Property
Public Property Let Height(ByVal value As Long)
   m_cMemDc.Height = value
End Property
Public Property Get Font() As IFont
   Set Font = m_font
End Property
Public Property Let Font(value As IFont)
   pSetFont value
End Property
Public Property Set Font(value As IFont)
   pSetFont value
End Property
Private Sub pSetFont(theFont As IFont)
   theFont.Clone m_font
End Sub


Public Sub Draw(ByVal lOutputDc As Long)
Dim tDrawR As RECT
Dim lhDC As Long

   ' set up the drawing rectangle:
   m_tR.Right = m_tR.Left + m_cMemDc.Width
   m_tR.Bottom = m_tR.Top + m_cMemDc.Height
   
   ' Get where we're drawing to:
   Dim lOffsetX As Long
   Dim lOffsetY As Long
   LSet tDrawR = m_tR
   If (m_bUseMemDc) Then
      lhDC = m_cMemDc.hdc
      OffsetRect tDrawR, -m_tR.Left, -m_tR.Top
   Else
      lhDC = lOutputDc
      lOffsetX = m_tR.Left
      lOffsetY = m_tR.Top
   End If
   
   ' draw the background:
   drawBackground lhDC, tDrawR
   
   Dim hFont As Long
   Dim hFontOld As Long
   hFont = SelectObject(lhDC, m_font.hFont)
   SetBkMode lhDC, TRANSPARENT
   ' draw the objects
   Dim i As Long
   For i = 1 To m_iDrawObjectCount
      drawObject lhDC, i, lOffsetX, lOffsetY
   Next i
   SelectObject lhDC, hFontOld
      
   ' if using a memory DC, we need to copy the result:
   If (m_bUseMemDc) Then
      m_cMemDc.Draw lOutputDc, , , , , m_tR.Left, m_tR.Top
   End If

End Sub
Private Sub drawBackground(ByVal lhDC As Long, tDrawR As RECT)
Dim hBr As Long
   hBr = GetSysColorBrush(vbWindowBackground And &H1F&)
   FillRect lhDC, tDrawR, hBr
   DeleteObject hBr
Dim hPen As Long
Dim hPenOld As Long
Dim tJunk As POINTAPI
   hPen = CreatePen(PS_SOLID, 1, GetSysColor(vbHighlight And &H1F&))
   hPenOld = SelectObject(lhDC, hPen)
   MoveToEx lhDC, tDrawR.Left, tDrawR.Top, tJunk
   LineTo lhDC, tDrawR.Right - 1, tDrawR.Top
   LineTo lhDC, tDrawR.Right - 1, tDrawR.Bottom - 1
   LineTo lhDC, tDrawR.Left, tDrawR.Bottom - 1
   LineTo lhDC, tDrawR.Left, tDrawR.Top
   SelectObject lhDC, hPenOld
   DeleteObject hPen
   
End Sub
Public Sub CreateObjects(ByVal iCount As Long)
   m_iDrawObjectCount = iCount
   ReDim Preserve m_tDrawObject(1 To m_iDrawObjectCount) As DrawObjectData
   Dim i As Long
   Dim lSize As Long
   Dim h As Single, s As Single, l As Single
   Dim r As Long, b As Long, g As Long
   Dim rf As Long, bf As Long, gf As Long
   RGBToHLS &H33, &H99, &HEE, h, s, l
   For i = 1 To m_iDrawObjectCount
      With m_tDrawObject(i)
         HLSToRGB h, s, l, r, g, b
         l = l * 0.95
         .backColor = RGB(r, g, b)
         HLSToRGB h, s, l * 4, rf, gf, bf
         .foreColor = RGB(rf, gf, bf)
         Do While (.iDirX = 0)
            .iDirX = Rnd * 8 - 4
         Loop
         Do While (.iDirY = 0)
            .iDirY = Rnd * 8 - 4
         Loop
         .sCaption = Hex(.backColor)
         .lSize = 32 + Rnd * 32
         .tP.x = Rnd * (m_cMemDc.Width - .lSize)
         .tP.y = Rnd * (m_cMemDc.Height - .lSize)
      End With
   Next i
End Sub

Private Sub drawObject(ByVal lhDC As Long, ByVal iIndex As Long, ByVal lOffsetX
 As Long, ByVal lOffsetY As Long)
   With m_tDrawObject(iIndex)
      ' update the position
      If (.tP.x + .lSize + .iDirX >= m_cMemDc.Width) Then
         .iDirX = -.iDirX
      End If
      If (.tP.x + .iDirX <= 0) Then
         .iDirX = -.iDirX
      End If
      If (.tP.y + .lSize + .iDirY >= m_cMemDc.Height) Then
         .iDirY = -.iDirY
      End If
      If (.tP.y + .iDirY <= 0) Then
         .iDirY = -.iDirY
      End If
      .tP.x = .tP.x + .iDirX
      .tP.y = .tP.y + .iDirY
      
      Dim hBr As Long
      Dim tR As RECT
      tR.Left = .tP.x
      tR.Top = .tP.y
      tR.Right = tR.Left + .lSize
      tR.Bottom = tR.Top + .lSize
      
      OffsetRect tR, lOffsetX, lOffsetY
      
      hBr = CreateSolidBrush(.backColor)
      FillRect lhDC, tR, hBr
      DeleteObject hBr
      
      SetTextColor lhDC, .foreColor
      DrawText lhDC, .sCaption, -1, tR, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
   End With
   
   
End Sub

Private Sub RGBToHLS( _
     ByVal r As Long, ByVal g As Long, ByVal b As Long, _
     h As Single, s As Single, l As Single _
     )
 Dim Max As Single
 Dim Min As Single
 Dim delta As Single
 Dim rR As Single, rG As Single, rB As Single

     rR = r / 255: rG = g / 255: rB = b / 255

 '{Given: rgb each in [0,1].
 ' Desired: h in [0,360] and s in [0,1], except if s=0, then h=UNDEFINED.}
         Max = Maximum(rR, rG, rB)
         Min = Minimum(rR, rG, rB)
             l = (Max + Min) / 2 '{This is the lightness}
         '{Next calculate saturation}
         If Max = Min Then
             'begin {Acrhomatic case}
             s = 0
             h = 0
             'end {Acrhomatic case}
         Else
             'begin {Chromatic case}
                 '{First calculate the saturation.}
             If l <= 0.5 Then
                 s = (Max - Min) / (Max + Min)
             Else
                 s = (Max - Min) / (2 - Max - Min)
             End If
             '{Next calculate the hue.}
             delta = Max - Min
             If rR = Max Then
                     h = (rG - rB) / delta '{Resulting color is between yellow
                      and magenta}
             ElseIf rG = Max Then
                 h = 2 + (rB - rR) / delta '{Resulting color is between cyan
                  and yellow}
             ElseIf rB = Max Then
                 h = 4 + (rR - rG) / delta '{Resulting color is between magenta
                  and cyan}
             End If
         'end {Chromatic Case}
     End If
 End Sub

Private Sub HLSToRGB( _
     ByVal h As Single, ByVal s As Single, ByVal l As Single, _
     r As Long, g As Long, b As Long _
     )
Dim rR As Single, rG As Single, rB As Single
Dim Min As Single, Max As Single

     If s = 0 Then
     ' Achromatic case:
     rR = l: rG = l: rB = l
     Else
     ' Chromatic case:
     ' delta = Max-Min
     If l <= 0.5 Then
         's = (Max - Min) / (Max + Min)
         ' Get Min value:
         Min = l * (1 - s)
     Else
         's = (Max - Min) / (2 - Max - Min)
         ' Get Min value:
         Min = l - s * (1 - l)
     End If
     ' Get the Max value:
     Max = 2 * l - Min
     
     ' Now depending on sector we can evaluate the h,l,s:
     If (h < 1) Then
         rR = Max
         If (h < 0) Then
             rG = Min
             rB = rG - h * (Max - Min)
         Else
             rB = Min
             rG = h * (Max - Min) + rB
         End If
     ElseIf (h < 3) Then
         rG = Max
         If (h < 2) Then
             rB = Min
             rR = rB - (h - 2) * (Max - Min)
         Else
             rR = Min
             rB = (h - 2) * (Max - Min) + rR
         End If
     Else
         rB = Max
         If (h < 4) Then
             rR = Min
             rG = rR - (h - 4) * (Max - Min)
         Else
             rG = Min
             rR = (h - 4) * (Max - Min) + rG
         End If
         
     End If
             
     End If
     r = rR * 255: g = rG * 255: b = rB * 255
 End Sub
 Private Function Maximum(rR As Single, rG As Single, rB As Single) As Single
   If (rR > rG) Then
      If (rR > rB) Then
         Maximum = rR
      Else
         Maximum = rB
      End If
   Else
      If (rB > rG) Then
         Maximum = rB
      Else
         Maximum = rG
      End If
   End If
End Function
Private Function Minimum(rR As Single, rG As Single, rB As Single) As Single
   If (rR < rG) Then
      If (rR < rB) Then
         Minimum = rR
      Else
         Minimum = rB
      End If
   Else
      If (rB < rG) Then
         Minimum = rB
      Else
         Minimum = rG
      End If
   End If
End Function


Private Sub Class_Initialize()
   Set m_cMemDc = New pcMemDC
   Dim s As New StdFont
   s.Name = "Arial"
   s.Size = 8
   Set m_font = s
End Sub