Lightening colors

On an ongoing project, I had to create lighter shades of a color. Since we were working with Excel 2007, I decided to use Range.Interior.TintAndShade to achieve the desired result. TintAndShade is a number between -1 and 1 that lightens or darkens a color. Initial tests showed it seemed to work fine. In the image below, the first row contains 5 ‘base’ colors. Each subsequent row contains a slightly lighter shade of that color until eventually we get white.

light01

The code to get the shades for 1 column is below. Select any number of cells in a column with the ‘base’ color as the first cell and run doTintAndShades. The above example used a selection of 8 cells in each column.

Option Explicit

Sub doTintAndShades()
    Dim I As Integer, Rng As Range
    Set Rng = Selection
    For I = 2 To Rng.Cells.Count
        With Rng.Cells(I).Interior
        .Color = Rng.Cells(1).Interior.Color
        .TintAndShade = (I – 1) / (Rng.Cells.Count – 1)
            End With
        Next I
    End Sub

Done, one would think. Well, not quite. With Yellow as the base color I got:
light021

After convincing myself that it wasn’t me nor my understanding of TintAndShade, I decided to separately lighten each of the primary colors Red, Green, and Blue.

Sub lightenRGB()
    Dim I As Integer, Rng As Range
    Dim R As Byte, G As Byte, B As Byte
    Set Rng = Selection
    With Rng.Cells(1).Interior
    R = .Color Mod 256
    G = .Color 256 Mod 256
    B = .Color (CLng(256) * 256)
        End With
    For I = 2 To Rng.Cells.Count
        With Rng.Cells(I).Interior
        .Color = RGB(R + (255 – R) * (I – 1) / (Rng.Cells.Count – 1), _
            G + (255 – G) * (I – 1) / (Rng.Cells.Count – 1), _
            B + (255 – B) * (I – 1) / (Rng.Cells.Count – 1))
            End With
        Next I
    End Sub

with the result:
light03

I then decided to check Excel 2010. The TintAndShade code works just fine. So, apparently, Microsoft fixed whatever ailed the Excel/Office 2007 TintAndShade property.

Posted in Uncategorized

4 thoughts on “Lightening colors

  1. Very nice Mike, but it doesn’t work for 2003 version of Excel, can this be done with a bit of tweaking?

  2. This is the code I use in Sparklines for Excel (works w/ Excel 2003, as it does not use TintAndShade)

    Option Explicit

    ‘For the FULL version of this module, please visit
    http://www.planet-source-code.com/vb
    ‘(The darken & brighten routines in this module are
    ‘slightly modified from that version)

    ‘Portions of this code marked with *** are converted from
    ‘C/C++ routines for RGB/HSL conversion found in the
    ‘Microsoft Knowledge Base (PD sample code):
    ‘http://support.microsoft.com/support/kb/articles/Q29/2/40.asp
    ‘In addition to the language conversion, some internal
    ‘calculations have been modified and converted to FP math to
    ‘reduce rounding errors.
    ‘Conversion to VB and original code by
    ‘Dan Redding (bwsoft@revealed.net)
    ‘http://home.revealed.net/bwsoft
    ‘Free to use, please give proper credit

    Public Const HSLMAX As Long = 240 ‘***
       ‘H, S and L values can be 0 – HSLMAX
       ‘240 matches what is used by MS Win;
       ‘any number less than 1 byte is OK;
       ‘works best if it is evenly divisible by 6
    Const RGBMAX As Long = 255 ‘***
       ‘R, G, and B value can be 0 – RGBMAX
    Const UNDEFINED As Long = (HSLMAX * 2 / 3) ‘***
       ‘Hue is undefined if Saturation = 0 (greyscale)

    Public Type HSLCol ‘Datatype used to pass HSL Color values
       Hue As Long
        Sat As Long
        Lum As Long
    End Type

    Public Function RGBRed(RGBCol As Long) As Long
    ‘Return the Red component from an RGB Color
       RGBRed = RGBCol And &HFF
    End Function

    Public Function RGBGreen(RGBCol As Long) As Long
    ‘Return the Green component from an RGB Color
       RGBGreen = ((RGBCol And &H100FF00) / &H100)
    End Function

    Public Function RGBBlue(RGBCol As Long) As Long
    ‘Return the Blue component from an RGB Color
       RGBBlue = (RGBCol And &HFF0000) / &H10000
    End Function

    Private Function iMax(a As Long, B As Long) _
        As Long
    ‘Return the Larger of two values
       iMax = IIf(a > B, a, B)
    End Function

    Private Function iMin(a As Long, B As Long) _
        As Long
    ‘Return the smaller of two values
       iMin = IIf(a < B, a, B)
    End Function

    Public Function RGBtoHSL(RGBCol As Long) As HSLCol ‘***
    ‘Returns an HSLCol datatype containing Hue, Luminescence
    ‘and Saturation; given an RGB Color value

    Dim R As Long, G As Long, B As Long
    Dim cMax As Long, cMin As Long
    Dim RDelta As Double, GDelta As Double, _
        BDelta As Double
    Dim H As Double, S As Double, L As Double
    Dim cMinus As Long, cPlus As Long
       
        R = RGBRed(RGBCol)
        G = RGBGreen(RGBCol)
        B = RGBBlue(RGBCol)
       
        cMax = iMax(iMax(R, G), B) ‘Highest and lowest
       cMin = iMin(iMin(R, G), B) ‘color values
       
        cMinus = cMax – cMin ‘Used to simplify the
       cPlus = cMax + cMin  ‘calculations somewhat.
       
        ‘Calculate luminescence (lightness)
       L = ((cPlus * HSLMAX) + RGBMAX) / (2 * RGBMAX)
       
        If cMax = cMin Then ‘achromatic (r=g=b, greyscale)
           S = 0 ‘Saturation 0 for greyscale
           H = UNDEFINED ‘Hue undefined for greyscale
       Else
            ‘Calculate color saturation
           If L <= (HSLMAX / 2) Then
                S = ((cMinus * HSLMAX) + 0.5) / cPlus
            Else
                S = ((cMinus * HSLMAX) + 0.5) / (2 * RGBMAX – cPlus)
            End If
       
            ‘Calculate hue
           RDelta = (((cMax – R) * (HSLMAX / 6)) + 0.5) / cMinus
            GDelta = (((cMax – G) * (HSLMAX / 6)) + 0.5) / cMinus
            BDelta = (((cMax – B) * (HSLMAX / 6)) + 0.5) / cMinus
       
            Select Case cMax
                Case CLng(R)
                    H = BDelta – GDelta
                Case CLng(G)
                    H = (HSLMAX / 3) + RDelta – BDelta
                Case CLng(B)
                    H = ((2 * HSLMAX) / 3) + GDelta – RDelta
            End Select
           
            If H < 0 Then H = H + HSLMAX
        End If
       
        RGBtoHSL.Hue = CInt(H)
        RGBtoHSL.Lum = CInt(L)
        RGBtoHSL.Sat = CInt(S)
    End Function

    Public Function HSLtoRGB(HueLumSat As HSLCol) As Long ‘***
       Dim R As Double, G As Double, B As Double
        Dim H As Double, L As Double, S As Double
        Dim Magic1 As Double, Magic2 As Double
       
        H = HueLumSat.Hue
        L = HueLumSat.Lum
        S = HueLumSat.Sat
       
        If CInt(S) = 0 Then ‘Greyscale
           R = (L * RGBMAX) / HSLMAX ‘luminescence,
                   ‘converted to the proper range
           G = R ‘All RGB values same in greyscale
           B = R
            If CInt(H) <> UNDEFINED Then
                ‘This is technically an error.
               ‘The RGBtoHSL routine will always return
               ‘Hue = UNDEFINED (160 when HSLMAX is 240)
               ‘when Sat = 0.
               ‘if you are writing a color mixer and
               ‘letting the user input color values,
               ‘you may want to set Hue = UNDEFINED
               ‘in this case.
           End If
        Else
            ‘Get the “Magic Numbers”
           If L <= HSLMAX / 2 Then
                Magic2 = (L * (HSLMAX + S) + 0.5) / HSLMAX
            Else
                Magic2 = L + S – ((L * S) + 0.5) / HSLMAX
            End If
           
            Magic1 = 2 * L – Magic2
           
            ‘get R, G, B; change units from HSLMAX range
           ‘to RGBMAX range
           R = (HuetoRGB(Magic1, Magic2, H + (HSLMAX / 3)) _
                * RGBMAX + 0.5) / HSLMAX
            G = (HuetoRGB(Magic1, Magic2, H) * RGBMAX + 0.5) / HSLMAX
            B = (HuetoRGB(Magic1, Magic2, H – (HSLMAX / 3)) _
                * RGBMAX + 0.5) / HSLMAX
           
        End If
       
        HSLtoRGB = RGB(CInt(R), CInt(G), CInt(B))
       
    End Function

    Private Function HuetoRGB(mag1 As Double, mag2 As Double, _
        ByVal Hue As Double) As Double ‘***
    ‘Utility function for HSLtoRGB

    ‘Range check
       If Hue < 0 Then
            Hue = Hue + HSLMAX
        ElseIf Hue > HSLMAX Then
            Hue = Hue – HSLMAX
        End If
       
        ‘Return r, g, or b value from parameters
       Select Case Hue ‘Values get progressively larger.
                   ‘Only the first true condition will execute
           Case Is < (HSLMAX / 6)
                HuetoRGB = (mag1 + (((mag2 – mag1) * Hue + _
                    (HSLMAX / 12)) / (HSLMAX / 6)))
            Case Is < (HSLMAX / 2)
                HuetoRGB = mag2
            Case Is < (HSLMAX * 2 / 3)
                HuetoRGB = (mag1 + (((mag2 – mag1) * _
                    ((HSLMAX * 2 / 3) – Hue) + _
                    (HSLMAX / 12)) / (HSLMAX / 6)))
            Case Else
                HuetoRGB = mag1
        End Select
    End Function

    Public Function ContrastingColor(RGBCol As Long) As Long
    ‘Returns Black or White, whichever will show up better
    ‘on the specified color.
    ‘Useful for setting label forecolors with transparent
    ‘backgrounds (send it the form backcolor – RGB value, not
    ‘system value!)
    ‘(also produces a monochrome negative when applied to
    ‘all pixels in an image)

    Dim HSL As HSLCol
        HSL = RGBtoHSL(RGBCol)
        If HSL.Lum > HSLMAX / 2 Then ContrastingColor = 0 _
            Else: ContrastingColor = &HFFFFFF
    End Function

    Public Function Brighten(RGBColor As Long, Percent As Double)
    ‘Lightens the color by a specifie percent, given as a Single
    ‘(10% = .10)

    Dim HSL As HSLCol, L As Long
        If Percent <= 0 Then
            Brighten = RGBColor
            Exit Function
        End If
       
        HSL = RGBtoHSL(RGBColor)
        L = HSL.Lum + (HSLMAX * Percent)
        If L > HSLMAX Then L = HSLMAX
        HSL.Lum = L
        Brighten = HSLtoRGB(HSL)
    End Function

    Public Function Darken(RGBColor As Long, Percent As Double)
    ‘Darkens the color by a specifie percent, given as a Single

    Dim HSL As HSLCol, L As Long
        If Percent <= 0 Then
            Darken = RGBColor
            Exit Function
        End If
       
        HSL = RGBtoHSL(RGBColor)
        L = HSL.Lum – (HSLMAX * Percent)
        If L < 0 Then L = 0
        HSL.Lum = L
        Darken = HSLtoRGB(HSL)
    End Function

    Public Function Blend(RGB1 As Long, RGB2 As Long, _
        Percent As Double) As Long
    ‘This one doesn’t really use the HSL routines, just the
    ‘RGB Component routines.  I threw it in as a bonus ;)
    ‘Takes two colors and blends them according to a
    ‘percentage given as a Single
    ‘For example, .3 will return a color 30% of the way
    ‘between the first color and the second.
    ‘.5, or 50%, will be an even blend (halfway)
    ‘Can create some nice effects inside a For loop

    Dim R As Long, r1 As Long, r2 As Long, _
        G As Long, G1 As Long, G2 As Long, _
        B As Long, B1 As Long, B2 As Long
       
        If Percent >= 1 Then
            Blend = RGB2
            Exit Function
        ElseIf Percent <= 0 Then
            Blend = RGB1
            Exit Function
        End If
       
        r1 = RGBRed(RGB1)
        r2 = RGBRed(RGB2)
        G1 = RGBGreen(RGB1)
        G2 = RGBGreen(RGB2)
        B1 = RGBBlue(RGB1)
        B2 = RGBBlue(RGB2)
       
        R = ((r2 * Percent) + (r1 * (1 – Percent)))
        G = ((G2 * Percent) + (G1 * (1 – Percent)))
        B = ((B2 * Percent) + (B1 * (1 – Percent)))
       
        Blend = RGB(R, G, B)
    End Function

  3. Thanks I get benifit from you Thanks a lot.
    some change add from other Web

    Sub lightenRGB()
    Dim I As Integer, Rng As Range
    Dim R As Byte, G As Byte, B As Byte
    Set Rng = Selection
    With Rng.Cells(1).Interior
    R = .Color Mod 256
    G = (.Color \ 256) Mod 256
    B = (.Color \ (CLng(256) * 256))

    End With
    For I = 2 To Rng.Cells.Count
    With Rng.Cells(I).Interior
    .Color = RGB(R + (255 – R) * (I – 1) / (Rng.Cells.Count – 1), _
    G + (255 – G) * (I – 1) / (Rng.Cells.Count – 1), _
    B + (255 – B) * (I – 1) / (Rng.Cells.Count – 1))
    End With
    Next I
    End Sub


Posting code? Use <pre> tags for VBA and <code> tags for inline.

Leave a Reply

Your email address will not be published.