HEX Color VBA

[jstevens]

I'm having a challenge using VBA to lighten a HEX color #424200 by 80%. The new HEX color number generated is not even close to the color I would expect.

I found a website that produces a new HEX color number which I'm trying to replicate through VBA.

Your thoughts are appreciated.

[HansV]

I have moved this thread from the Excel forum to the VB/VBA forum since it is not specific to Excel.

[snb]

Code: Select all

Sub M_snb()
   Cells(6, 2).Interior.TintAndShade = 0.8
End Sub

[HansV]

I have no idea what algorithm that site uses. Here is an attempt that doesn't use Excel properties, but it doesn't produce the same result as the site you linked to.

Code: Select all

Function Lighten(colr As Long, perc As Double) As Long
    Dim r As Long, g As Long, b As Long
    r = colr Mod 256
    g = (colr \ 256) Mod 256
    b = (colr \ 256) \ 256
    r = r + perc * (255 - r)
    g = g + perc * (255 - g)
    b = b + perc * (255 - b)
    Lighten = RGB(r, g, b)
End Function

Use like this:

Code: Select all

Sub Test()
    Dim ColorIn as Long, ColorOut As Long
    ColorIn = &H424200
    ColorOut = Lighten(ColorIn, 0.8)
    Debug.Print ColorOut
End Sub

[SpeakEasy]

> no idea what algorithm

I'd hazard it is messing with the luminance, something along the lines of:

newluminance = currentluminance + lightenpercent * (240 - currentluminance) / 100

This is also pretty much the algorithm used by the ColorAdjustLuma API call.

So here's an example using the first method:

Code: Select all

Private Declare Function ColorHLSToRGB Lib "shlwapi.dll" (ByVal wHue As Integer, ByVal wLuminance As Integer, ByVal wSaturation As Integer) As Long
Private Declare Sub ColorRGBToHLS Lib "shlwapi.dll" (ByVal clrRGB As Long, ByRef pwHue As Integer, ByRef pwLuminance As Integer, ByRef pwSaturation As Integer)

Private Function LightenRGB(crRGB As Long, lightenpercent As Integer) As Long
    Dim hue As Integer
    Dim luminance As Integer
    Dim saturation As Integer
    
    ColorRGBToHLS crRGB, hue, luminance, saturation 'get current hls values
    LightenRGB = ColorHLSToRGB(hue, luminance + lightenpercent * (240 - luminance) / 100, saturation) 'mess with luminance and return corrected COLORREF
End Function

And here's an example of the second

Code: Select all

Private Declare Function ColorAdjustLuma Lib "shlwapi.dll" (ByVal clrRGB As Long, ByVal n As Long, ByVal fscale As Long) As Long

Private Function Luma(crRGB As Long, lightenpercent As Integer, Optional fscale As Boolean = True) As Long
    Luma = ColorAdjustLuma(crRGB, lightenpercent * 10, fscale) 'mess with luminance and return corrected COLORREF
End Function

[HansV]

Thanks!

[jstevens]

Hans/snb,

Thank you for your suggestions. I was using similar code to what Hans suggested but like Hans was not getting the Hex number of what I expected.

sub's suggestion appears to be changing the color in the cell to yellow but the Hex number of that yellow cell is #a6ffff (pale cyan) it should be #ffffa6 (pale yellow).

In summary, neither suggestion is returning the correct Hex number of #ffffa6.

I'll give SpeakEasy's suggestion a try.

[SpeakEasy]

>the correct Hex number of #ffffa6

I suspect that you need to understand the difference between COLORREFs and RGB values. Both can be represented in Hex, but VBA colour functions (and the API) work with COLORREFs. The difference is basically the order of the bytes

A COLORREF is bbggrr, whilst RGB is rrggbb

[jstevens]

Hans, sub, SpeakEasy,

I was able to develop VBA based on your suggestions. I have attached a sample workbook containing the code.

el_HexColor.xlsm

[snb]

I made:

Code: Select all

Sub M_snb()
  With Cells(6, 2).Interior
    .Color = &H424200
    .TintAndShade = 0.8
    .Color = RGB(.Color \ 256 ^ 2, (.Color Mod 256 ^ 2) \ 256, .Color Mod 256)
  End With
End Sub

In your file:

Code: Select all

Sub M_Process_List()
  sn = Range("hexlist")
  
  For j = 1 To UBound(sn)
    With Cells(j + 1, 13).Interior
      .Color = Replace(sn(j, 1), "#", "&h")
      .TintAndShade = 0.8
      .Color = RGB(.Color \ 256 ^ 2, (.Color Mod 256 ^ 2) \ 255, .Color Mod 256)
      .Parent.Offset(, 1) = Hex(.Color)
      .Parent.Offset(, 2) = .Color \ 256 ^ 2 & ", " & (.Color Mod 256 ^ 2) \ 256 & ", " & .Color Mod 256
    End With
  Next
End Sub

[SpeakEasy]

Here's a quick utility that will swap between COLORREF and RGB Hex that might prove useful

Code: Select all

Option Explicit

Public Type ColourBytes
    r As Byte
    g As Byte
    b As Byte
    a As Byte ' always 0, whether representing COLORREF or RGB
End Type

Public Type ColourWord
    dword As Long
End Type

' Swaps a long representing a COLORREF to the RGB Hex value and vice versa
Public Function Swap(Source As Long) As Long
    Dim cw As ColourWord
    Dim cb As ColourBytes

    cw.dword = Source
    LSet cb = cw
    cb.r = cb.r Xor cb.b
    cb.b = cb.r Xor cb.b
    cb.r = cb.r Xor cb.b
    LSet cw = cb
    Swap = cw.dword
    
End Function

[HansV]

Thanks again!