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’
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 |
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.
Be the first to comment