## VBA实现的HSL与RGB颜色转换

RGB与HSL的颜色转换经常被用到，网上也有不少相应的实现，但VBA实现的相对难见到，因此水文工具集使用VBA实现RGB和HSL颜色转换代码，以供参考，具体源代码如下：

```'================================
' 颜色转换算法
' RGB2HSL
' HSL2RGB
' http://kuaitb.com
'================================
Private Type HSL
H As Double    ' 0-360
S As Double    ' 0-1
L As Double    ' 0-1
End Type

Private Type Colour
R As Double    ' 0-1
G As Double    ' 0-1
B As Double    ' 0-1
End Type

' Calculate HSL from RGB
' Hue is in degrees
' Lightness is between 0 and 1
' Saturation is between 0 and 1
Private Function RGB2HSL(ByRef c1 As Colour) As HSL
Dim themin As Double, themax As Double, delta As Double
Dim c2 As HSL

themin = MinD(c1.R, MinD(c1.G, c1.B))
themax = MaxD(c1.R, MaxD(c1.G, c1.B))

delta = themax - themin
c2.L = (themin + themax) / 2
c2.S = 0

If ((c2.L > 0) And (c2.L < 1)) Then
If (c2.L < 0.5) Then
c2.S = delta / (2 * c2.L)
Else
c2.S = delta / (2 - 2 * c2.L)
End If
End If

c2.H = 0

If (delta > 0) Then
If ((themax = c1.R) And (themax <> c1.G)) Then _
c2.H = c2.H + (c1.G - c1.B) / delta
If ((themax = c1.G) And (themax <> c1.B)) Then _
c2.H = c2.H + (2 + (c1.B - c1.R) / delta)
If ((themax = c1.B) And (themax <> c1.R)) Then _
c2.H = c2.H + (4 + (c1.R - c1.G) / delta)

c2.H = c2.H * 60
End If

RGB2HSL = c2
End Function

' Calculate RGB from HSL, reverse of RGB2HSL()
' Hue is in degrees
' Lightness is between 0 and 1
' Saturation is between 0 and 1
Private Function HSL2RGB(ByRef c1 As HSL) As Colour
Dim c2 As Colour, sat As Colour, ctmp As Colour

Do While (c1.H < 0)
c1.H = c1.H + 360
Loop

Do While (c1.H > 360)
c1.H = c1.H - 360
Loop

If (c1.H < 120) Then
sat.R = (120 - c1.H) / 60
sat.G = c1.H / 60
sat.B = 0
ElseIf (c1.H < 240) Then
sat.R = 0
sat.G = (240 - c1.H) / 60
sat.B = (c1.H - 120) / 60
Else
sat.R = (c1.H - 240) / 60
sat.G = 0
sat.B = (360 - c1.H) / 60
End If

sat.R = MinD(sat.R, 1)
sat.G = MinD(sat.G, 1)
sat.B = MinD(sat.B, 1)

ctmp.R = 2 * c1.S * sat.R + (1 - c1.S)
ctmp.G = 2 * c1.S * sat.G + (1 - c1.S)
ctmp.B = 2 * c1.S * sat.B + (1 - c1.S)

If (c1.L < 0.5) Then
c2.R = c1.L * ctmp.R
c2.G = c1.L * ctmp.G
c2.B = c1.L * ctmp.B
Else
c2.R = (1 - c1.L) * ctmp.R + 2 * c1.L - 1
c2.G = (1 - c1.L) * ctmp.G + 2 * c1.L - 1
c2.B = (1 - c1.L) * ctmp.B + 2 * c1.L - 1
End If

HSL2RGB = c2
End Function

Private Function MinD(ByVal inA As Double, ByVal inB As Double) As Double
If (inA < inB) Then MinD = inA Else MinD = inB
End Function

Private Function MaxD(ByVal inA As Double, ByVal inB As Double) As Double
If (inA > inB) Then MaxD = inA Else MaxD = inB
End Function

Function NewColour(aR As Double, aG As Double, aB As Double) As Colour
With NewColour
.R = aR
.G = aG
.B = aB
End With
End Function

Sub test()
Dim MyHSL As HSL

' Convert RGB to HSL
MyHSL = RGB2HSL(NewColour(63 / 255, 124 / 255, 81 / 255))

' Display HSL
Debug.Print "RGB -> HSL: " & CStr(CLng((MyHSL.H / 360) * 240)) & ", " & _
CStr(CLng(MyHSL.S * 240)) & ", " & CStr(CLng(MyHSL.L * 240))

With HSL2RGB(MyHSL)    ' Convert HSL back to RGB and display
Debug.Print "HSL -> RGB: " & CStr(CLng(.R * &HFF)) & ", " & _
CStr(CLng(.G * &HFF)) & ", " & CStr(CLng(.B * &HFF))
End With
End Sub
```