Color ramp library

What can you learn here ?
  • ramp color scales
  • gradient between colors
  • Use a ramp library

Generalized Color Ramps

If you read A tagCloud in OutlookHow to create a tag cloud or Create a heatmap in Excel you would have seen reference to a heatmap scale. This is specific form of color ramp that calculates a color ranging from blue through red depending on it's value compared to the rest of the range it is in. Here we will look at creating a generalized color ramp, and an extensible VBA library of useful ramps.

As usual this code is implemented in the cDataSet.xlsm module downloadable from Download Complete Projects.  There is a Google Apps Script version of this library if you are a Google Docs user.   See Charts and color ramps for how to make interesting charts using color ramps

How it works

You provide 2 or more colors, and the difference between their red, green and blue component values is calculated. A single RGB color is provided that you can use to represent the input value. 

Example Color ramps




Here is the code to produce the ramps shown above.
Public Sub testHeatMapScaleRamp()
    Dim m As Long, n As Long, r As Range
    Set r = Sheets("heatmapramp").Range("a1")
    r.Worksheet.Cells.Interior.color = vbWhite
    Const npoints = 200
    For m = 0 To npoints
        r.Offset(, m).Interior.color = _
            rampLibraryRGB("heatmap", 0, npoints, m)
        r.Offset(1, m).Interior.color = _
            rampLibraryRGB("heatmaptowhite", 0, npoints, m)
        r.Offset(2, m).Interior.color = _
            rampLibraryRGB("blacktowhite", 0, npoints, m)
        r.Offset(3, m).Interior.color = _
            rampLibraryRGB("whitetoblack", 0, npoints, m)
        r.Offset(4, m).Interior.color = _
            rampLibraryRGB("hotinthemiddle", 0, npoints, m)
        r.Offset(5, m).Interior.color = _
            rampLibraryRGB("candylime", 0, npoints, m)
        r.Offset(6, m).Interior.color = _
            rampLibraryRGB("heatcolorblind", 0, npoints, m)
        r.Offset(7, m).Interior.color = _
            rampLibraryRGB("gethotquick", 0, npoints, m)
         r.Offset(8, m).Interior.color = _
            rampLibraryRGB("greensweep", 0, npoints, m)
    Next m

    
End Sub

Here is the colorramp library defining them

Public Function rampLibraryRGB(sName As String, min As Variant, _
                max As Variant, Value As Variant, _
                Optional brighten As Double = 0) As Long
                
    Select Case Trim(LCase(sName))
        Case "heatmaptowhite"
            rampLibraryRGB = colorRamp(min, max, Value, _
                            Array(vbBlue, vbGreen, vbYellow, vbRed, vbWhite), , _
                            brighten)
        
        Case "heatmap"
            rampLibraryRGB = colorRamp(min, max, Value, _
                            Array(vbBlue, vbGreen, vbYellow, vbRed), , _
                            brighten)
        
        Case "blacktowhite"
            rampLibraryRGB = colorRamp(min, max, Value, _
                            Array(vbBlack, vbWhite), , brighten)
        
        Case "whitetoblack"
            rampLibraryRGB = colorRamp(min, max, Value, _
                            Array(vbWhite, vbBlack), , brighten)
                     
        Case "hotinthemiddle"
            rampLibraryRGB = colorRamp(min, max, Value, _
                            Array(vbBlue, vbGreen, vbYellow, vbRed, _
                                    vbYellow, vbGreen, vbBlue), , brighten)
                                    
        Case "candylime"
            rampLibraryRGB = colorRamp(min, max, Value, _
                            Array(RGB(255, 77, 121), RGB(255, 121, 77), _
                                    RGB(255, 210, 77), RGB(210, 255, 77)), , _
                                    brighten)
                                    
        Case "heatcolorblind"
            rampLibraryRGB = colorRamp(min, max, Value, _
                            Array(vbBlack, vbBlue, vbRed, vbWhite), , brighten)
                            
        Case "gethotquick"
            rampLibraryRGB = colorRamp(min, max, Value, _
                            Array(vbBlue, vbGreen, vbYellow, vbRed), _
                            Array(0, 0.1, 0.25, 1), brighten)
               
        Case "greensweep"
            rampLibraryRGB = colorRamp(min, max, Value, _
                            Array(RGB(153, 204, 51), RGB(51, 204, 179)), , _
                            brighten)
               
        Case "terrain"
            rampLibraryRGB = colorRamp(min, max, Value, _
                            Array(vbBlack, RGB(0, 46, 184), RGB(0, 138, 184), _
                            RGB(0, 184, 138), _
                            RGB(138, 184, 0), RGB(184, 138, 0), _
                            RGB(138, 0, 184), vbWhite), , _
                            brighten)
                            
        Case Else
            Debug.Assert False
            
    End Select
    
End Function

ColorRamp Function

Intermediate colors

Aside from the min, max and value that you want the color calculated for, you can also provide an array of as many colors as you want. colorRamp will use these to 'pass through' - so for example a heatmap would be Array(vbBlue, vbGreen, vbYellow, vbRed). To get the exact effect  you want, just add some more intermediate colors. 

Ramp speed

By default, the rate at which the colors evolve between intermediate or 'milestone' colors is evenly divided. However if you wanted to modify that - for example the library entry 'gethotquick', spends longer on the red tone colors than on the blue - you can specify the ramp up speed for each milestone color as below -

         Case "gethotquick"
            rampLibraryRGB = colorRamp(min, max, Value, _
                            Array(vbBlue, vbGreen, vbYellow, vbRed), _
                            Array(0, 0.1, 0.25, 1))

Code

Here us the code for the colorRamp function.


Public Function colorRamp(min As Variant, _
                max As Variant, Value As Variant, _
                Optional mileStones As Variant, _
                Optional fractionStones As Variant, _
                Optional brighten As Double = 1)
    
    ' create a value from a colorramp going through the array of milestones
    Dim spread As Double, ratio As Double, red As Double, _
                    green As Double, blue As Double, j As Long, _
                    lb As Long, ub As Long, cb As Long, r As Double, i As Long
                    
    '----defaults and set up milestones on ramp
    Dim ms() As Long
    Dim fs() As Double
    If IsMissing(mileStones) Then
        ReDim ms(0 To 4)
        ms(0) = vbBlue
        ms(1) = vbGreen
        ms(2) = vbYellow
        ms(3) = vbRed
        ms(4) = vbWhite
    Else
        ReDim ms(0 To UBound(mileStones) - LBound(mileStones))
        j = 0
        For i = LBound(mileStones) To UBound(mileStones)
            ms(j) = mileStones(i)
            j = j + 1
        Next i
    End If
    ' tedious this is
    lb = LBound(ms)
    ub = UBound(ms)
    cb = ub - lb + 1
    ' only 1 milestone - thats the color
    If cb = 1 Then
        colorRamp = ms(lb)
        Exit Function
    End If
        
    If Not IsMissing(fractionStones) Then
        If UBound(fractionStones) - LBound(fractionStones) <> _
            cb - 1 Then
            MsgBox ("no of fractions must equal number of steps")
            Exit Function
        Else
            ReDim fs(lb To ub)
            j = lb
            For i = LBound(fractionStones) To UBound(fractionStones)
                fs(j) = fractionStones(i)
                j = j + 1
            Next i

        End If
    Else
        ReDim fs(lb To ub)
        For i = lb + 1 To ub
            fs(i) = i / (cb - 1)
        Next i
    End If
    'spread of range
    spread = max - min
    Debug.Assert spread >= 0
    ratio = (Value - min) / spread
    Debug.Assert ratio >= 0 And ratio <= 1
    ' find which slot
    For i = lb + 1 To ub
        If ratio <= fs(i) Then
            r = (ratio - fs(i - 1)) / (fs(i) - fs(i - 1))
            red = rgbRed(ms(i - 1)) + (rgbRed(ms(i)) - rgbRed(ms(i - 1))) * r
            blue = rgbBlue(ms(i - 1)) + (rgbBlue(ms(i)) - rgbBlue(ms(i - 1))) * r
            green = rgbGreen(ms(i - 1)) + (rgbGreen(ms(i)) - rgbGreen(ms(i - 1))) * r
            colorRamp = RGB(lumRGB(red, brighten), _
                            lumRGB(green, brighten), _
                            lumRGB(blue, brighten))
            Exit Function
        End If
    Next i
    Debug.Assert False
   
End Function

Private Function lumRGB(rgbCom As Double, brighten As Double) As Double
    Dim x As Double
    x = rgbCom * brighten
    If x > 255 Then x = 255
    If x < 0 Then x = 0
    lumRGB = x
    
End Function


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

Learning Apps Script, (and transitioning from VBA) are covered comprehensively in my my book, Going Gas - from VBA to Apps script, available All formats are available now from O'Reilly,Amazon and all good bookshops. You can also read a preview on O'Reilly

If you prefer Video style learning I also have two courses available. also published by O'Reilly.
Google Apps Script for Developers and Google Apps Script for Beginners.





Comments