vbAccelerator - Contents of code file: mHLSRGB.bas

Attribute VB_Name = "mHLSRGB"
Option Explicit

Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long)
 As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
 Long
Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Public Sub DrawHLSBox( _
      ByRef picThis As PictureBox _
   )
Dim h As Single
Dim s As Single
Dim r As Long, g As Long, b As Long
Dim lHDC As Long
Dim tR As RECT
Dim lColor As Long
Dim hBr As Long

   picThis.Cls
   lHDC = picThis.hdc
   picThis.Width = 240 * Screen.TwipsPerPixelX
   picThis.Height = 256 * Screen.TwipsPerPixelY
   tR.Right = 1
   tR.Bottom = 2
   For h = -40 To 200
      For s = 128 To 0 Step -1
         HLSToRGB h / 40, s / 128, 0.5, r, g, b
         lColor = RGB(r, g, b)
         hBr = CreateSolidBrush(lColor)
         FillRect lHDC, tR, hBr
         DeleteObject hBr
         tR.Top = tR.Top + 2
         tR.Bottom = tR.Top + 2
      Next s
      tR.Left = tR.Left + 1
      tR.Right = tR.Left + 1
      tR.Top = 0
      tR.Bottom = 2
   Next h
   
End Sub
Public Sub DrawLuminanceBox( _
      ByRef picThis As PictureBox, _
      ByVal h As Single, _
      ByVal s As Single _
   )
Dim r As Long, g As Long, b As Long
Dim lHDC As Long
Dim tR As RECT
Dim lColor As Long
Dim hBr As Long
Dim l As Long
   
   lHDC = picThis.hdc
   tR.Right = picThis.ScaleWidth \ Screen.TwipsPerPixelX
   tR.Bottom = 1
   For l = 255 To 0 Step -1
      HLSToRGB h, s, l / 255, r, g, b
      hBr = CreateSolidBrush(RGB(r, g, b))
      FillRect lHDC, tR, hBr
      DeleteObject hBr
      tR.Top = tR.Top + 1
      tR.Bottom = tR.Bottom + 1
   Next l
   picThis.Refresh
End Sub


Public 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
            '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( _
      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