Find nearest color match

Let’s say you have a color, and you want to find the closest match in defined color scheme set. The first problem is defining what closest means. It’s not a simple problem to solve.

There are a number of approaches to this, the simplest being to measure the euclidean distance between two colors in a 3D color space – for example RGB, HSL, HSV etc. Here’s and article that shows how to do that.

However, these mathematical approaches do not really adjust for color perception. Another color model  CIEL*a*b*, has used various algorithms over the years to create better matches to take account of perceived color differences.

Page Content hide
1 CIEDE2000
2 Does it work?
3 The gory details

CIEDE2000

This is the latest CIE algorithm (from  wikipedia) for comparing two colors for closeness. It’s a monster

I thought I may as well implement this in VBA , javaScript and google apps script to add to my color function libraries. Here’s the VBA version. Luckily I found (by Gaurav Sharma, Wencheng Wu,Edul N. Dalal) this paper to get me started. The GAS version is at Color Matching in GAS

Does it work?

Amazingly, it works very well. In Looking up color table I’ve built up a table of schemes such as Pantone, dulux etc through various web scraping sessions, and now have getting on for 10,000 named colors in that library. To test it, I generate some random colors, then look up the closest in each of the schemes in my color table. Here’s the result – I tried to find a match for the first column of random numbers in all of the color table, and also in each of the individual color schemes. Their names are shown along with their color. Pretty close in all cases. Of course the html color scheme is rather short, but still close results.

The gory details

It’s not pretty, but here are the main functions in color match algorithm.
Public Function cieDe2000(p1 As colorProps, p2 As colorProps) As Double
    ' calculates the distance between 2 colors using CIEDE200
    ' see http://www.ece.rochester.edu/~gsharma/cieDe2000/cieDe2000noteCRNA.pdf
    Dim c1 As Double, c2 As Double, _
        c As Double, g As Double, a1 As Double, b1 As Double, _
        a2 As Double, b2 As Double, c1Tick As Double, c2Tick As Double, _
        h1 As Double, h2 As Double, dh As Double, dl As Double, dc As Double, _
        lTickAvg As Double, cTickAvg As Double, hTickAvg As Double, l50 As Double, sl As Double, _
        sc As Double, t As Double, sh As Double, dTheta As Double, kp As Double, _
        rc As Double, kl As Double, kc As Double, kh As Double, dlk As Double, _
        dck As Double, dhk As Double, rt As Double, dBigH As Double
    
    kp = 25 ^ 7
    kl = 1
    kc = 1
    kh = 1
    
    ' calculate c & g values
    c1 = Sqr(p1.aStar ^ 2 + p1.bStar ^ 2)
    c2 = Sqr(p2.aStar ^ 2 + p2.bStar ^ 2)
    c = (c1 + c2) / 2
    g = 0.5 * (1 - Sqr(c ^ 7 / (c ^ 7 + kp)))

    ' adjusted ab*
    a1 = (1 + g) * p1.aStar
    a2 = (1 + g) * p2.aStar

    ' adjusted cs
    c1Tick = Sqr(a1 ^ 2 + p1.bStar ^ 2)
    c2Tick = Sqr(a2 ^ 2 + p2.bStar ^ 2)

    ' adjusted h
    h1 = computeH(a1, p1.bStar)
    h2 = computeH(a2, p2.bStar)

    
    ' deltas
    If (h2 - h1 > 180) Then '1
        dh = h2 - h1 - 360
    ElseIf (h2 - h1 < -180) Then ' 2
        dh = h2 - h1 + 360
    Else '0
        dh = h2 - h1
    End If

    dl = p2.LStar - p1.LStar
    dc = c2Tick - c1Tick
    dBigH = (2 * Sqr(c1Tick * c2Tick) * sIn(toRadians(dh / 2)))

    ' averages
    lTickAvg = (p1.LStar + p2.LStar) / 2
    cTickAvg = (c1Tick + c2Tick) / 2

    
    If (c1Tick * c2Tick = 0) Then '3
        hTickAvg = h1 + h2
    
    ElseIf (Abs(h2 - h1) <= 180) Then '0
        hTickAvg = (h1 + h2) / 2
    
    ElseIf (h2 + h1 < 360) Then '1
        hTickAvg = (h1 + h2) / 2 + 180
    
    Else '2
        hTickAvg = (h1 + h2) / 2 - 180
    End If
    
    l50 = (lTickAvg - 50) ^ 2
    sl = 1 + (0.015 * l50 / Sqr(20 + l50))
    sc = 1 + 0.045 * cTickAvg
    t = 1 - 0.17 * Cos(toRadians(hTickAvg - 30)) + 0.24 * _
            Cos(toRadians(2 * hTickAvg)) + 0.32 * _
            Cos(toRadians(3 * hTickAvg + 6)) - 0.2 * _
            Cos(toRadians(4 * hTickAvg - 63))

    sh = 1 + 0.015 * cTickAvg * t

    dTheta = 30 * Exp(-1 * ((hTickAvg - 275) / 25) ^ 2)
    rc = 2 * Sqr(cTickAvg ^ 7 / (cTickAvg ^ 7 + kp))
    rt = -sIn(toRadians(2 * dTheta)) * rc
    dlk = dl / sl / kl
    dck = dc / sc / kc
    dhk = dBigH / sh / kh
    cieDe2000 = Sqr(dlk ^ 2 + dck ^ 2 + dhk ^ 2 + rt * dck * dhk)
    
End Function
Public Function compareColors(rgb1 As Long, rgb2 As Long, _
            Optional compareType As eCompareColor = eCompareColor.eccieDe2000) As Double
    Dim p1 As colorProps, p2 As colorProps
    p1 = makeColorProps(rgb1)
    p2 = makeColorProps(rgb2)
    Select Case compareType
        Case eCompareColor.eccieDe2000
            compareColors = cieDe2000(p1, p2)
            
        Case Else
            Debug.Assert False
    
    End Select
    
End Function
Private Function computeH(a As Double, b As Double) As Double
    If (a = 0 And b = 0) Then
        computeH = 0
    ElseIf (b >= 0) Then
        computeH = Application.WorksheetFunction.Degrees(Application.WorksheetFunction.Atan2(a, b))
    Else
        computeH = Application.WorksheetFunction.Degrees(Application.WorksheetFunction.Atan2(a, b)) + 360
    End If
End Function
Private Function rgbToLab(rgbColor As Long) As colorProps
    ' adapted from // http://www.easyrgb.com/
    Dim x As Double, y As Double, z As Double, _
        p As colorProps

    p = rgbToXyz(rgbColor)
    
    x = xyzCIECorrection(p.x / refWhiteX)
    y = xyzCIECorrection(p.y / refWhiteY)
    z = xyzCIECorrection(p.z / refWhiteZ)

    p.LStar = (116 * y) - 16
    p.aStar = 500 * (x - y)
    p.bStar = 200 * (y - z)

    rgbToLab = p
End Function
Private Function rgbToXyz(rgbColor As Long) As colorProps
    ' adapted from // http://www.easyrgb.com/
    Dim r As Double, g As Double, b As Double, _
        p As colorProps
    
    r = xyzCorrection(rgbRed(rgbColor) / 255) * 100
    g = xyzCorrection(rgbGreen(rgbColor) / 255) * 100
    b = xyzCorrection(rgbBlue(rgbColor) / 255) * 100
    
    p.x = r * 0.4124 + g * 0.3576 + b * 0.1805
    p.y = r * 0.2126 + g * 0.7152 + b * 0.0722
    p.z = r * 0.0193 + g * 0.1192 + b * 0.9505

    rgbToXyz = p
End Function
rivate Function xyzCIECorrection(v As Double) As Double
    If (v > 0.008856) Then
        xyzCIECorrection = (v ^ (1 / 3))
    Else
        xyzCIECorrection = (7.787 * v) + (16 / 116)
    End If
End Function
Private Function rgbToXyz(rgbColor As Long) As colorProps
    ' adapted from // http://www.easyrgb.com/
    Dim r As Double, g As Double, b As Double, _
        p As colorProps
    
    r = xyzCorrection(rgbRed(rgbColor) / 255) * 100
    g = xyzCorrection(rgbGreen(rgbColor) / 255) * 100
    b = xyzCorrection(rgbBlue(rgbColor) / 255) * 100
    
    p.x = r * 0.4124 + g * 0.3576 + b * 0.1805
    p.y = r * 0.2126 + g * 0.7152 + b * 0.0722
    p.z = r * 0.0193 + g * 0.1192 + b * 0.9505

    rgbToXyz = p
End Function
Private Function xyzCorrection(v As Double) As Double
    If (v > 0.04045) Then
        xyzCorrection = ((v + 0.055) / 1.055) ^ 2.4
    Else
        xyzCorrection = v / 12.92
    End If
End Function

and here’ the test procedure that generated the above

Private Function getClosestColorMap(ds As cDataSet, target As Long, _
            Optional scheme As String = vbNullString) As cCell
    Dim dc As cCell, dmin As Double, d As Double, dr As cDataRow
    Set dc = Nothing
    For Each dr In ds.rows
        If (scheme = vbNullString Or dr.value("scheme") = scheme) Then
            d = compareColors(target, htmlHexToRgb(dr.value("hex")))
            If dc Is Nothing Or d < dmin Then
                dmin = d
                Set dc = dr.cell("hex")
            End If
        End If
    Next dr
    Set getClosestColorMap = dc
End Function
Public Sub SeedSomeColors()
    Dim r As Range, n As Long, ncells As Long, ds As cDataSet, t As Long, dc As cCell, _
        dr As cDataRow, p As colorProps, a As Variant, i As Long
    Set r = firstCell(wholeSheet("comparecolors"))
    ncells = 30
    Application.Calculation = xlCalculationManual
    Randomize
    ' create some random colors to test against
    For n = 1 To ncells
        With r.Offset(n, 0)
            p = makeColorProps(Int((vbWhite - vbBlack + 1) * Rnd + vbBlack))
            .Interior.color = p.rgb
            .Font.color = p.textColor
            .value = p.htmlHex
        End With
    Next n

    ' now look in the colortable
    Set ds = getcolorMap()
    
    ' cycle through various schemes
    a = Array("", "pms", "pfh", "dulux", "htm")
    For i = LBound(a) To UBound(a)
        For n = 1 To ncells
            t = r.Offset(n, 0).Interior.color
            Set dc = getClosestColorMap(ds, t, CStr(a(i)))
            If Not dc Is Nothing Then
                With r.Offset(n, 1 + i - LBound(a))
                    p = makeColorProps(htmlHexToRgb(dc.value))
                    .value = ds.value(dc.row, "name")
                    .Interior.color = p.rgb
                    .Font.color = p.textColor
                End With
            End If
        Next n
    Next i
    

    Application.Calculation = xlCalculationAutomatic
    ds.tearDown
    
End Sub
More color related topics?

For help and more information join our forum, follow the blog or and contact me on Twitter