VBA procedures for CIE LabLch and HSL color scheming

In playing around with color in VBA I introduced a bunch of functions to manipulate various color spaces from VBA. Digging into the whole topic a little more, I wondered if it would be possible to create color palettes from a single color. After some research, I figured that I would try the cie LabLch and HSL color spaces to see how I might do this.

The maths behind all this turned out to be pretty interesting, and I had to dust off some rusty trig concepts to get this working, but I now have a very extensive set of VBA functions to manipulate color.

First attempts

I decided to generate a set of 5 colors evenly spaced according to hue, lightness and saturation using each model to compare how close they were. Later on I’ll make some functions for other schemes, and of course create a google apps script version.
I generated some random colors and made the palettes as described above. Here are the generated results.
I prefer the results using the hsl space. What do you think?
Here’s the code to create these random palettes. You can download the cDataSet.xlsm workbook from the Excel Liberation site to play around with it. It’s the worksheet named ‘palette’
Public Sub getSomePalettes()
    Dim n As Long, r As Range, ncells As Long, p As colorProps, swatchSize As Long, _
        a() As colorProps, i As Long, models As Variant, prop As Variant, _
        done As Long, j As Long, k As Long, rowHeight As Double, spaceHeight As Double, _
        columnWidth As Double, spaceWidth As Double, rowOff As Long, colOff As Long, t As Long
        
    Set r = firstCell(wholeSheet("palette"))
    models = Array("lch", "hsl")
    prop = Array("hue", "lightness", "saturation")
    ncells = 9
    swatchSize = 5
    done = 0
    rowHeight = 20
    columnWidth = 6
    spaceHeight = rowHeight / 5
    spaceWidth = columnWidth / 5
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Randomize
    '--------create some random colors to test against, and format worksheet
    For n = 1 To ncells
        With r.Offset((n - 1) * (2 + arrayLength(models)) + 1, 0).Resize(arrayLength(models) + 1)
            ' basic section for this random color
            ''p = makeColorProps(Int((vbWhite - vbBlack + 1) * Rnd + vbBlack))
            p = makeColorProps(htmlHexToRgb(r.Offset(1 + (n - 1) * 4, 0).Resize(1, 1).value))
            .Interior.color = p.rgb
            .Font.color = p.textColor
            .value = Empty
            .rowHeight = rowHeight
            ' name the models
            For k = LBound(models) To UBound(models)
                .Resize(1, 1).Offset(k - LBound(models) + 1).value = models(k)
            Next k
            .Resize(arrayLength(models), 1).Offset(1).BorderAround xlContinuous
            
            ' add a break line with reference color
            With .Resize(1, arrayLength(prop) * (swatchSize + 1) + 1)
                .Interior.color = p.rgb
                .Font.color = p.textColor
                .columnWidth = columnWidth
                With .Resize(, 1)
                    .value = p.htmlHex
                    .columnWidth = columnWidth * 3
                End With
                .Offset(0, 0).BorderAround xlContinuous
            End With
            
            ' add column breaks between props and name them
            For k = LBound(prop) To UBound(prop)
                With .Resize(, 1).Offset(, 1 + (swatchSize + 1) * (k - LBound(prop)))
                    .columnWidth = spaceWidth
                    .Resize(1, 1).Offset(, 1).value = prop(k)
                End With
            Next k
            
            ' add a break line after
            With .Offset(arrayLength(models) + 1).Resize(1)
                .rowHeight = spaceHeight
                .Interior.color = vbWhite
                .Font.color = vbBlack
                .value = Empty
            End With
        End With
        
    Next n

    '------------create various palettes
    For k = LBound(models) To UBound(models)
        For j = LBound(prop) To UBound(prop)
            For n = 1 To ncells
                ' this is the header row/narrow column
                rowOff = 1 + (n - 1) * (2 + arrayLength(models))
                colOff = 1 + (1 + swatchSize) * (j - LBound(prop))
                With r.Offset(rowOff, colOff)
                    
                    a = makeAPalette(.Interior.color, CStr(models(k)), _
                                CStr(prop(j)), swatchSize)

                    With .Offset(k - LBound(models) + 1)
                        .Interior.color = vbWhite
                        For i = LBound(a) To UBound(a)
                            With .Offset(, 1 + i - LBound(a))
                                .Interior.color = a(i).rgb
                                .value = rgbToHTMLHex(a(i).rgb)
                            End With
                            .Offset(, 1).Resize(, swatchSize).BorderAround xlContinuous
                        Next i
                    End With
                
                End With
            Next n
        Next j
    Next k
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
Public Function makeAPalette(rgbColor As Long, Optional model As String = "lch", _
        Optional iType As String = "hue", Optional howMany As Long = 5) As colorProps()
    ' return an array of palettable colors
    Dim g As Double, a() As colorProps, p As colorProps, _
        i As Long, h As Double, top As Double, pv As String
    ReDim a(1 To howMany)
    
    If iType = "hue" Then
        top = 360
    Else
        top = 100
    End If
    
    ' step
    g = top / howMany
    p = makeColorProps(rgbColor)
    
    If iType = "hue" Then
        If model = "lch" Then
            h = p.hStar
            pv = "hStar"
        Else
            h = p.hue
            pv = "hue"
        End If
    
    ElseIf iType = "saturation" Then
        If model = "lch" Then
            h = p.cStar
            pv = "cstar"
        Else
            h = p.saturation
            pv = "saturation"
        End If

    Else
        If model = "lch" Then
            h = p.LStar
            pv = "lstar"
        Else
            h = p.lightness
            pv = "lightness"
        End If
        
    End If
    
    For i = 1 To howMany
        If h > top Then h = h - top
        If model = "lch" Then
            If iType = "hue" Then
                p.hStar = h
            ElseIf iType = "saturation" Then
                p.cStar = h
            Else
                p.LStar = h
            End If
            p = makeColorProps(lchToRgb(p))
        Else
            If iType = "hue" Then
                p.hue = h
            ElseIf iType = "saturation" Then
                p.saturation = h
            Else
                p.lightness = h
            End If
            p = makeColorProps(hslToRgb(p))
        End If
        a(i) = p
        h = h + g

    Next i
    sortColorProp a, LBound(a), UBound(a), pv
    makeAPalette = a
End Function

The color manipulation functions.

Here is the code, or you can find it in the downloads section, the cDataSet.xlsm workbook on  the Excel liberation site. Here are the functions you’ll find there.

 

About brucemcp 225 Articles
I am a Google Developer Expert and decided to investigate Google Apps Script in my spare time. The more I investigated the more content I created so this site is extremely rich. Now, in 2019, a lot of things have disappeared or don’t work anymore due to Google having retired some stuff. I am however leaving things as is and where I came across some deprecated stuff, I have indicated it. I decided to write a book about it and to also create videos to teach developers who want to learn Google Apps Script. If you find the material contained in this site useful, you can support me by buying my books and or videos.