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
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.