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.
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.
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:
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.
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:
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.
Very nice Mike, but it doesn’t work for 2003 version of Excel, can this be done with a bit of tweaking?
Who’s Mike?
Excel 2003 supports only a limited palette of 56 colors.
This is the code I use in Sparklines for Excel (works w/ Excel 2003, as it does not use TintAndShade)
‘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
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