There are a few items on this site that cover color ramps and other color manipulation topics. I’ve built up a few snippets on color management in VBA so I thought I should centralize them for easy reference. There is a Google Apps Script of most of this stuff on this site also. See Playing around with GAS color
Getting started with color
RGB
Convert to and from htmlHex
Luminance
Luma is a measure of light in a color that can be used to determine whether there is a good contrast between two colors. I use it to pick the color of text I should use given a background color.
Calculate luminance
Contrast ratio
This is the ratio of contrast between 2 colors. The w3 organization has recommendations on suitable contrast ratios that improve legibility.
Calculate contrast ratio
You can see it gets harder to read the low contrast ratios.
CYMK Cyan, Yellow, Magenta, Black (the k of cymk), is another color representation model that is used in printing systems. If you look at the ink colors in your printer you’ll see that typically they are these colors. Whereas RGB was an additive system (red, green, blue adding together to eventually make white at maximum values), cymk is a subtractive system (maximum values are black). When you consider that CYMK is about printing, and a blank sheet of paper is white this makes sense. This is a very different color model to RGB and there is not a direct mapping, but here’s an approximation of how to convert between the two
p.black = min(1 - p.red / 255, 1 - p.green / 255, 1 - p.blue / 255)
If p.black < 1 Then
p.cyan = (1 - p.red / 255 - p.black) / (1 - p.black)
p.magenta = (1 - p.green / 255 - p.black) / (1 - p.black)
p.yellow = (1 - p.blue / 255 - p.black) / (1 - p.black)
End If
HSL
This is a model based on Hue, saturation and lightness. Hue is 0- 360, and saturation and lightness is a percentage. Acknowledgement to http://www.easyrgb.com/ for the algorithm.
Calculate HSL
Public Function hslToRgb(p As colorProps) As Long
' adapted from // http://www.easyrgb.com/
Dim x1 As Double, x2 As Double, h As Double, s As Double, l As Double, _
red As Double, green As Double, blue As Double
h = p.hue / 360
s = p.saturation / 100
l = p.lightness / 100
If s = 0 Then
red = l * 255
green = l * 255
blue = l * 255
Else
If l < 0.5 Then
x2 = l * (1 + s)
Else
x2 = (l + s) - (l * s)
End If
x1 = 2 * l - x2
red = 255 * hueToRgb(x1, x2, h + (1 / 3))
green = 255 * hueToRgb(x1, x2, h)
blue = 255 * hueToRgb(x1, x2, h - (1 / 3))
End If
hslToRgb = rgb(red, green, blue)
End Function
Public Function rgbToHsl(rgbColor As Long) As colorProps
' adapted from // http://www.easyrgb.com/
Dim r As Double, g As Double, b As Double, d As Double, _
dr As Double, dg As Double, db As Double, mn As Double, mx As Double, _
p As colorProps
r = rgbRed(rgbColor) / 255
g = rgbGreen(rgbColor) / 255
b = rgbBlue(rgbColor) / 255
mn = min(r, g, b)
mx = max(r, g, b)
d = mx - mn
' HSL sets here
p.hue = 0
p.saturation = 0
' lightness
p.lightness = (mx + mn) / 2
If (d <> 0) Then
' saturation
If (p.lightness < 0.5) Then
p.saturation = d / (mx + mn)
Else
p.saturation = d / (2 - mx - mn)
End If
' hue
dr = (((mx - r) / 6) + (d / 2)) / d
dg = (((mx - g) / 6) + (d / 2)) / d
db = (((mx - b) / 6) + (d / 2)) / d
If r = mx Then
p.hue = db - dg
ElseIf g = mx Then
p.hue = (1 / 3) + dr - db
Else
p.hue = (2 / 3) + dg - dr
End If
'force between 0 and 1
If p.hue < 0 Then p.hue = p.hue + 1
If p.hue > 1 Then p.hue = p.hue - 1
Debug.Assert p.hue >= 0 And p.hue <= 1
End If
p.hue = p.hue * 360
p.saturation = p.saturation * 100
p.lightness = p.lightness * 100
rgbToHsl = p
End Function
Private Function hueToRgb(a As Double, b As Double, h As Double) As Double
' adapted from // http://www.easyrgb.com/
If h < 0 Then h = h + 1
If h > 1 Then h = h - 1
Debug.Assert h >= 0 And h <= 1
If (6 * h < 1) Then
hueToRgb = a + (b - a) * 6 * h
ElseIf (2 * h < 1) Then
hueToRgb = b
ElseIf (3 * h < 2) Then
hueToRgb = a + (b - a) * ((2 / 3) - h) * 6
Else
hueToRgb = a
End If
End Function
Text color
Although you can figure out contrasting colors by manipulating the r,g and b values, I think it’s better to use just black and white, and deciding on which by the value of the luminance – high luminance, use black, low, use white.
Colorprops custom type.
Since all these can be useful and are straightforward to calculated, I use a custom type to store them all in. That way I can other color spaces as I need to without disturbing much. So far the type looks like this
Public Type colorProps
' this is a single type to hold everything i know how to calculate about a color
rgb As Long
red As Long
green As Long
blue As Long
htmlHex As String
textColor As Long
luminance As Double
contrastRatio As Double
cyan As Double
magenta As Double
yellow As Double
black As Double
hue As Double
saturation As Double
lightness As Double
End Type
Populating the colorProps type
Public Function makeColorProps(rgbColor As Long) As colorProps
Dim p As colorProps, p2 As colorProps
'store the source color
p.rgb = rgbColor
'split the components
p.red = rgbRed(rgbColor)
p.green = rgbGreen(rgbColor)
p.blue = rgbBlue(rgbColor)
'the html hex rgb equivalent
p.htmlHex = rgbToHTMLHex(rgbColor)
'the w3 algo for luminance
p.luminance = w3Luminance(rgbColor)
'determine whether black or white background
If (p.luminance < 0.5) Then
p.textColor = vbWhite
Else
p.textColor = vbBlack
End If
'contrast ratio - to comply with w3 recs 1.4 should be at least 10:1 for text
p.contrastRatio = contrastRatio(p.textColor, p.rgb)
' myck - just an estimate
p.black = min(1 - p.red / 255, 1 - p.green / 255, 1 - p.blue / 255)
If p.black < 1 Then
p.cyan = (1 - p.red / 255 - p.black) / (1 - p.black)
p.magenta = (1 - p.green / 255 - p.black) / (1 - p.black)
p.yellow = (1 - p.blue / 255 - p.black) / (1 - p.black)
End If
' calculate hsl + hsv and other wierd things
p2 = rgbToHsl(p.rgb)
p.hue = p2.hue
p.saturation = p2.saturation
p.lightness = p2.lightness
p.value = rgbToHsv(p.rgb).value
p2 = rgbToXyz(p.rgb)
p.x = p2.x
p.y = p2.y
p.z = p2.z
p2 = rgbToLab(p.rgb)
p.LStar = p2.LStar
p.aStar = p2.aStar
p.bStar = p2.bStar
p2 = rgbToLch(p.rgb)
p.cStar = p2.cStar
p.hStar = p2.hStar
makeColorProps = p
End Function
The color table
In the cDataSet.xlsm workbook (colorTable tab), there is a large table of colors. These are Pantone colors, html colors, dulux paint colors and various others. I’ll be adding to them over time, but also creating a REST queryable source that will allow you look up colors by type and name. Here’s the headings and the beginning of that table
The 4th column onwards were all calculated using the formulas described above. To understand the code below you’ll probably need to be familiar with Data Manipulation Classes, which are used for excel data abstraction. Pretty straightforward usage for the purposes of this.
Updating the color map
Public Sub colorMap()
Dim dr As cDataRow, p As colorProps
With getcolorMap(False)
' get all we know about each pantone color
For Each dr In .rows
With dr
' get all we know about this color
p = makeColorProps(htmlHexToRgb(.toString("hex")))
.cell("magenta").value = p.magenta
.cell("yellow").value = p.yellow
.cell("black").value = p.black
.cell("cyan").value = p.cyan
.cell("red").value = p.red
.cell("green").value = p.green
.cell("blue").value = p.blue
.cell("htmlHex").value = p.htmlHex
.cell("rgb").value = p.rgb
.cell("textcolor").value = p.textColor
.cell("luminance").value = p.luminance
.cell("contrastRatio").value = p.contrastRatio
.cell("value").value = p.value
.cell("hue").value = p.hue
.cell("saturation").value = p.saturation
.cell("lightness").value = p.lightness
.cell("x").value = p.x
.cell("y").value = p.y
.cell("z").value = p.z
.cell("lstar").value = p.LStar
.cell("astar").value = p.aStar
.cell("bstar").value = p.bStar
.cell("cstar").value = p.cStar
.cell("hstar").value = p.hStar
' color the row with and use a friendly text color
.where.Interior.color = p.rgb
.where.Font.color = p.textColor
End With
Next dr
.bigCommit
.tearDown
End With
End Sub
Public Function getcolorMap(Optional curt As Boolean = True) As cDataSet
Dim ds As cDataSet
Set ds = New cDataSet
If curt Then
ds.populateData toEmptyRow(wholeSheet("colorTable").Resize(, 3)), , , True, , , , "name"
Else
ds.populateData wholeSheet("colorTable"), , , True, , , True, "name"
End If
Set getcolorMap = ds
End Function
For help and more information join our forum,follow the blog or follow me on twitter .