Playing around with colors in VBA

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

 

Let’s start with a few of the color concepts that we’ll use in the functions I’m going to show you. All the functions mentioned can be found in the usefulColorStuff module of the cDataSet.xlsm workbook.
 

RGB

 

The RGB color model is covered here and is the simplest representation of color model, whose main usage is for the specification of color on electronic devices such as computer screens. The combination of values ranging from 0-255 for each of the colors red, green and blue (hence RGB) leads to a particular color. In VBA these can be combined with the RGB(r,g,b) function to produce a single number which can be applied, for example as the background color of a cell. That gives a possible range of 0-16777215 different colors, where rgb(255,255,255) = 16777215 – the color white, and rgb(0,0,0) gives 0 – the color black.
 
 
For web design, these color codes are normally represented as hexadecimal, from #0 to #ffffff, made up of the hex values for #red.green.blue. One thing to watch out for is that the order of bytes is reversed from the natural VBA order.
 
 
For example hex(rgb(255,0,0)) is #ff but the hexHtml representation for rgb(255,0,0) is #ff0000. The byte order is imply reversed. Here are some functions to convert back and forwards to RGB
 
 

Extract the individual color codes from

Public Function rgbRed(rgbColor As Long) As Long
    rgbRed = rgbColor Mod &H100
End Function
Public Function rgbGreen(rgbColor As Long) As Long
    rgbGreen = (rgbColor \ &H100) Mod &H100
End Function
Public Function rgbBlue(rgbColor As Long) As Long
    rgbBlue = (rgbColor \ &H10000) Mod &H100
End Function

Convert to and from htmlHex

Public Function rgbToHTMLHex(rgbColor As Long) As String

    ' just swap the colors round for rgb to bgr
    rgbToHTMLHex = "#" & maskFormat(Hex(rgb(rgbBlue(rgbColor), _
            rgbGreen(rgbColor), rgbRed(rgbColor))), "000000")

End Function

Private Function maskFormat(sIn As String, f As String) As String
    Dim s As String
    s = sIn
    If Len(s) < Len(f) Then
        s = left(f, Len(f) - Len(s)) &amp; s
    End If
    maskFormat = s
End Function

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

Public Function w3Luminance(rgbColor As Long) As Double
' this is based on
' http://en.wikipedia.org/wiki/Luma_(video)

  w3Luminance = (0.2126 * ((rgbRed(rgbColor) / 255) ^ 2.2)) + _
         (0.7152 * ((rgbGreen(rgbColor) / 255) ^ 2.2)) + _
         (0.0722 * ((rgbBlue(rgbColor) / 255) ^ 2.2))

End Function

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

Public Function contrastRatio(rgbColorA As Long, rgbColorB As Long) As Double
    Dim lumA As Double, lumB As Double
    lumA = w3Luminance(rgbColorA)
    lumB = w3Luminance(rgbColorB)

    contrastRatio = (max(lumA, lumB) + 0.05) / (min(lumA, lumB) + 0.05)

End Function

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