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.

#### CIEDE2000

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?

#### The gory details

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

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