vbAccelerator - Contents of code file: cHexColourPicker.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cHexColourPicker"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Type BITMAP '24 bytes
   bmType As Long
   bmWidth As Long
   bmHeight As Long
   bmWidthBytes As Long
   bmPlanes As Integer
   bmBitsPixel As Integer
   bmBits As Long
End Type
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 SetBrushOrgEx Lib "gdi32" (ByVal hdc As Long, ByVal
 nXOrg As Long, ByVal nYOrg As Long, lppt As Any) As Long
Private Declare Function UnrealizeObject Lib "gdi32" (ByVal hObject 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 Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As
 Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal
 dwRop As Long) As Long
Private Declare Function CreateBitmapIndirect Lib "gdi32" (lpBitmap As BITMAP)
 As Long
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long)
 As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR
 As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Const CLR_INVALID = -1
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal
 crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal
 crColor As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal
 hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long,
 ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As
 Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As
 Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal
 hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long)
 As Long

Private Declare Function LoadImageString Lib "user32" Alias "LoadImageA" ( _
      ByVal hInst As Long, ByVal lpsz As String, _
      ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long)
       As Long
Private Declare Function LoadImageLong Lib "user32" Alias "LoadImageA" ( _
      ByVal hInst As Long, ByVal lpsz As Long, _
      ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long)
       As Long
Private Const LR_LOADFROMFILE As Long = &H10
Private Const IMAGE_ICON As Long = 1

Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Function DrawIconEx Lib "user32" ( _
      ByVal hdc As Long, _
      ByVal xLeft As Long, ByVal yTop As Long, _
      ByVal hIcon As Long, _
      ByVal cxWidth As Long, ByVal cyWidth As Long, _
      ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, _
      ByVal diFlags As Long) As Boolean
Private Const DI_NORMAL As Long = &H3

Public Enum EPBRasterOperations
   PATCOPY = &HF00021  ' (DWORD) dest = pattern
   PATINVERT = &H5A0049        ' (DWORD) dest = pattern XOR dest
   PATPAINT = &HFB0A09        ' (DWORD) dest = DPSnoo
End Enum

Private m_hdc As Long
Private m_hBmp As Long
Private m_hBmpOld As Long
Private m_tBM As BITMAP

Private Type tCell
   X As Long
   Y As Long
   Color As Long
End Type
Private m_tCell() As tCell
Private m_iCount As Long
Private m_iSelected As Long
Private m_lSize As Long

Private m_hSelIcon As Long
Private m_bInIDE As Boolean


Public Sub Create(ByRef lIDRes As Long)
Dim sPic As StdPicture
Dim hBmpRes As Long
Dim hDCRes As Long
Dim hBmpResOld As Long

   ' Demonstrates how to create a black & white (1bpp) bitmap
   ' from a VB resource:
   
   ' Clear up if not already:
   Destroy

   ' Load from resource file:
   Set sPic = LoadResPicture(lIDRes, vbResBitmap)
   hBmpRes = sPic.Handle
   GetObjectAPI hBmpRes, LenB(m_tBM), m_tBM
   
   ' Need to get this into a mono bitmap,
   ' since VB insists on only giving us a system colour
   ' depth bitmap... sigh
   hDCRes = CreateCompatibleDC(0)
   hBmpResOld = SelectObject(hDCRes, hBmpRes)
   
   ' Create the mono DC & bitmap to hold the result:
   m_hdc = CreateCompatibleDC(0)
   m_hBmp = CreateCompatibleBitmap(m_hdc, m_tBM.bmWidth, m_tBM.bmHeight)
   m_hBmpOld = SelectObject(m_hdc, m_hBmp)
   
   BitBlt m_hdc, 0, 0, m_tBM.bmWidth, m_tBM.bmHeight, hDCRes, 0, 0, vbSrcCopy
      
   ' Clear up mono work DC:
   SelectObject hDCRes, hBmpResOld
   DeleteDC hDCRes
   ' VB will delete hBmpRes when sPic goes out of scope
               
   ' Load the icon:
   If (IsInIDE()) Then
      Dim sIconFile As String
      sIconFile = App.Path & "/home/Resources/Babbage/Office_Style_Colour_Picker/hexSelection.ico"
      m_hSelIcon = LoadImageString(App.hInstance, sIconFile, IMAGE_ICON, 32,
       32, LR_LOADFROMFILE)
   Else
      m_hSelIcon = LoadImageLong(App.hInstance, 101, IMAGE_ICON, 32, 32, 0)
   End If
               
End Sub

Private Function IsInIDE() As Boolean
   Debug.Assert (SetIDEFlag())
   IsInIDE = m_bInIDE
End Function
Private Function SetIDEFlag() As Boolean
   m_bInIDE = True
   SetIDEFlag = m_bInIDE
End Function

Public Property Get ColorCount() As Long
   ColorCount = m_iCount
End Property
Public Property Get Color(ByVal index As Long) As OLE_COLOR
   Color = m_tCell(index).Color
End Property
Public Property Get R(ByVal index As Long) As Byte
   R = (m_tCell(index).Color And &HFF&)
End Property
Public Property Get G(ByVal index As Long) As Byte
   G = ((m_tCell(index).Color And &HFF00&) \ &H100&)
End Property
Public Property Get B(ByVal index As Long) As Byte
   B = ((m_tCell(index).Color And &HFF0000) \ &H10000)
End Property
Public Property Get H(ByVal index As Long) As Double
Dim hr As Single, lr As Single, sr As Single
   RGBToHSL R(index), B(index), G(index), hr, lr, sr
   H = hr
End Property
Public Property Get L(ByVal index As Long) As Double
Dim hr As Single, lr As Single, sr As Single
   RGBToHSL R(index), B(index), G(index), hr, lr, sr
   L = lr
End Property
Public Property Get S(ByVal index As Long) As Double
Dim hr As Single, lr As Single, sr As Single
   RGBToHSL R(index), B(index), G(index), hr, lr, sr
   S = sr
End Property

Public Property Get Selected() As Long
   Selected = m_iSelected
End Property
Public Property Let Selected(ByVal lIndex As Long)
   m_iSelected = lIndex
End Property

Public Function HitTest(ByVal X As Long, ByVal Y As Long) As Long
Dim i As Long
Dim cellX As Long
Dim cellY As Long
   For i = 1 To m_iCount
      cellX = m_tCell(i).X
      If (X >= cellX) And (X <= cellX + m_tBM.bmWidth) Then
         cellY = m_tCell(i).Y
         If (Y >= cellY) And (Y <= cellY + m_tBM.bmHeight) Then
            HitTest = i
            Exit For
         End If
      End If
   Next i
End Function

Private Sub Draw( _
      ByVal hdc As Long, _
      ByVal X As Long, ByVal Y As Long, _
      ByVal oColor As OLE_COLOR _
   )
   
   ' Demonstrates how to draw any black & white bitmap onto a DC so
   ' that the white area is coloured oColor and the black area is
   ' masked out.  >very< useful!
   
   ' Set the DC white where the mono bitmap is white, but leave the
   ' remainder of the area unaffected by blt with the OR flag -
   ' 0 has no effect, 1 forces the display to go white.
   SetTextColor m_hdc, &H0
   SetTextColor hdc, &H0
   SetBkColor m_hdc, &HFFFFFF
   SetBkColor hdc, &HFFFFFF
   BitBlt hdc, X, Y, m_tBM.bmWidth, m_tBM.bmHeight, m_hdc, 0, 0, vbSrcPaint
   
   ' Set the black area to map onto white (SetTextColor) and then
   ' map the white area onto the colour we want to show the bitmap
   ' as.  Then blt using the AND flag.  1 has no effect on the background,
   ' whereas the white area ANDed with the colour displays in the colour.
   SetTextColor m_hdc, &HFFFFFF
   SetTextColor hdc, &HFFFFFF
   SetBkColor m_hdc, TranslateColor(oColor)
   SetBkColor hdc, TranslateColor(oColor)
   BitBlt hdc, X, Y, m_tBM.bmWidth, m_tBM.bmHeight, m_hdc, 0, 0, vbSrcAnd
   
End Sub

Public Sub DrawPicker( _
      ByVal hdc As Long, _
      ByVal Left As Long, _
      ByVal Top As Long, _
      Optional ByVal Size As Long = 13, _
      Optional ByVal Saturation As Single = 1, _
      Optional ByVal MinLuminance As Single = 0.5 _
   )
Dim lX As Long
Dim lY1 As Long, lY2 As Long
Dim lStep As Long
Dim iXStep As Long, iYStep As Long
Dim lXC As Long, lYC As Long
Dim fMaxD As Single
Dim bNewSize As Boolean
Dim iCellIndex As Long

   bNewSize = (Size <> m_lSize)
   m_lSize = Size

   If Size Mod 2 = 0 Then
      ' Must be odd size:
      Size = Size + 1
   End If

   lStep = Size
   lX = Left
   lY1 = Top + (Size \ 2 + 1) * (m_tBM.bmHeight - 4)
   lY2 = lY1
   lXC = lX + (Size \ 2) * m_tBM.bmWidth
   lYC = lY1
   fMaxD = Sqr((lX - lXC) * (lX - lXC) + (lY1 - lYC) * (lY1 - lYC))
   
   For iYStep = 1 To Size \ 2 + 1
      For iXStep = Size To 1 Step -1
         ' Draw the hex:
         iCellIndex = iCellIndex + 1
         If (bNewSize) Then
            m_iCount = iCellIndex
            ReDim Preserve m_tCell(1 To m_iCount) As tCell
         End If
         m_tCell(iCellIndex).X = lX
         m_tCell(iCellIndex).Y = lY1
         m_tCell(iCellIndex).Color = ColFor(MinLuminance, Saturation, fMaxD,
          lXC, lYC, lX, lY1)
         Draw hdc, lX, lY1, m_tCell(iCellIndex).Color
         If Not (lY1 = lY2) Then
            iCellIndex = iCellIndex + 1
            If (bNewSize) Then
               m_iCount = iCellIndex
               ReDim Preserve m_tCell(1 To m_iCount) As tCell
            End If
            m_tCell(iCellIndex).X = lX
            m_tCell(iCellIndex).Y = lY2
            m_tCell(iCellIndex).Color = ColFor(MinLuminance, Saturation, fMaxD,
             lXC, lYC, lX, lY2)
            Draw hdc, lX, lY2, m_tCell(iCellIndex).Color
         End If
         lX = lX + m_tBM.bmWidth
      Next iXStep
      Size = Size - 1
      lY1 = lY1 - (m_tBM.bmHeight - 3)
      lY2 = lY2 + (m_tBM.bmHeight - 3)
      lX = Left + iYStep * (m_tBM.bmWidth \ 2)
   Next iYStep
   
   If (m_iSelected > 0) And (m_iSelected <= m_iCount) Then
      DrawIconEx hdc, m_tCell(m_iSelected).X - 7, m_tCell(m_iSelected).Y - 7,
       m_hSelIcon, _
         32, 32, 0, 0, DI_NORMAL
   End If
   
End Sub
Private Function ColFor( _
      ByVal lMin As Single, _
      ByVal S As Single, _
      ByVal fMaxD As Single, _
      ByVal lXC As Long, ByVal lYC As Long, _
      ByVal lX As Long, ByVal lY As Long _
   ) As Long
Dim H As Single, L As Single
Dim R As Long, G As Long, B As Long
Dim opp As Long, adj As Long
Dim angle As Single

   ' Opposite & Adjacent of triangle
   adj = lX - lXC
   opp = lY - lYC

   ' Saturation defaults to max:
   
   ' distance from centre is luminance:
   L = Sqr(opp * opp + adj * adj)
   L = (fMaxD - L) / fMaxD
   ' Map so minimum luminance is 0.5 (the saturated colour)
   L = lMin + L * (1 - lMin)
   
   ' angle is the hue:
   If adj = 0 Then
      If lY < lYC Then
         angle = 2
      Else
         angle = 5
      End If
   Else
      angle = Atn(opp / adj)
      ' Convert to an angle -1 to 5
      angle = angle * 180 / 3.14
      If Sgn(opp) = 1 Then
         If Sgn(adj) = 1 Then
            ' 90 +
            angle = 90 - angle
         Else
            ' +ve angle
            angle = 270 + Abs(angle)
         End If
      Else
         If Sgn(adj) = 1 Then
            ' 180+
            angle = 90 + Abs(angle)
         Else
            ' 270+
            angle = 270 - angle
         End If
      End If
      angle = angle / 60 - 1
   End If
   
   
   HLSToRGB angle, S, L, R, G, B
   If R < 0 Then R = 0
   If G < 0 Then G = 0
   If B < 0 Then B = 0
   If R > 255 Then R = 255
   If G > 255 Then G = 255
   If B > 255 Then B = 255
   ColFor = RGB(R, G, B)
   
End Function

Public Sub Destroy()
   ' Clear up
   If Not (m_hBmpOld = 0) Then
      SelectObject m_hdc, m_hBmpOld
      m_hBmpOld = 0
   End If
   If Not (m_hBmp = 0) Then
      DeleteObject m_hBmp
      m_hBmp = 0
   End If
   If Not (m_hdc = 0) Then
      DeleteDC m_hdc
      m_hdc = 0
   End If
   If Not (m_hSelIcon = 0) Then
      DestroyIcon m_hSelIcon
      m_hSelIcon = 0
   End If
End Sub

Private Function TranslateColor(ByVal oClr As OLE_COLOR, _
                        Optional hPal As Long = 0) As Long
    ' Convert Automation color to Windows color
    If OleTranslateColor(oClr, hPal, TranslateColor) Then
        TranslateColor = CLR_INVALID
    End If
End Function


Public Sub RGBToHSL( _
      R As Long, G As Long, 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
            'Debug.Print h
            'h = h * 60
           'If h < 0# Then
           '     h = h + 360            '{Make degrees be nonnegative}
           'End If
        'end {Chromatic Case}
      End If
'end {RGB_to_HLS}
End Sub

Public Sub HLSToRGB( _
      H As Single, S As Single, 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_Terminate()
   Destroy
End Sub