Color()

Appearance is important.

If we want our first impressions to be impressive, we need to address color use. We see color usage before we see model structure and certainly before we see project functionality. We react to color without thinking. We are trained to recognize random colors and rainbow pallets as childish. The key to looking professional is to start with our client's color pallet. We can see this in their marketing materials and logos.

Color() was designed to help us apply a color pallet across all Excel objects: Worksheets, Tables, PivotTables, Charts, Slicers, User Forms, etc.. Color() provides a standard color number for a given Excel object. We tell it what object type we need a color for and Color() provides the appropriate color. In this way, all objects of the same type will have consistent colors matched to our workbook's color theme.

NOTE!
Color() is an old routine. It debuted before Excel had Styles (Microsoft keeps copying my ideas!) and long before most of my clients' Excel versions supported Styles. Today, we should apply Styles to much of what Color() addresses but I still use Color() in almost every project to apply corporate branding to things Styles does not address, such as user forms and user form elements. I also use Color() to create corporate branded Styles with BXL Format.

To tell Color() what object type we need a color for, we pass to Color() a Color Request Type which is an enumeration called crRequestTypes shown below.

Enum crRequestTypes 'Color Request Types

crReset

crLogo

crSkin

crForm

crFormFont

crFrame

crFrameFont

crButton

crButtonFont

crButtonGlow

crButtonGlowFont

crDark

crDarkFont

crLight

crLightFont

crAccentDark

crAccentDarkFont

crAccent

crAccentFont

crAccentlight

crAccentLightFont

crTableStyle

crPivotTableStyle

crSlicerStyle

crTimelineStyle

crBackground

crChartStyle

crChartColor

crChartColorFont

crChartArea

crPlotArea

crChartTitleLocation

crChartLegendLocation

crLogoPath

[_cr]

End Enum

crRequestTypes should be placed at the top of the module that contains the function: Color().

Color() contains an array of color defaults. Color() creates the array by splitting its constant, sDefault. If we want different theme colors applied to different objects we can change sDefault or we can use an optional Skin table. Below is a sample Skin table. If our workbook includes a table like this named Skin, Color() will use it instead of sDefault.

Function Color(ByVal ColorType As crRequestTypes, _

Optional ByVal oWorkbook As Workbook = Nothing) As Variant

' Description:Get a Color from Skin Table or Pallet

' Inputs: ColorType Color Request Type

' Outputs: Me Success:Color or Picture

' Failure:Null

' Requisites: Table: Skin (optional)

' Routines: me.Exists

' Routines: me.Tables

' Example: Selection.Interior.Color = Color(crAccent)

' Date Ini Modification

' 07/08/03 CWH Initial Development

' 06/03/14 CWH Added *DefaultTableStyle,*DefaultPivotTableStyle

' 09/04/14 CWH Better handling of Picture pathing

' 10/06/14 CWH Added oWorkbook Parameter

' 06/25/15 CWH Accommodated running Excel from illegal directory (ex. web)

' 12/16/15 CWH Changed how oWorkbook is determined when not sent

' 01/28/16 CWH Added ChartStyle and SlicerStyle

' 04/29/17 CWH Fixed problem when Skin.jpg is not found

' 06/30/17 CWH Accommodated old Skin tables

' 08/21/18 CWH Ditched Styles for Colors

' 09/06/18 CWH Reversed Backcolors for Fonts

' 11/02/18 CWH WTH? Can't access ThemeColorScheme if Workbook has protected sheets

' 04/01/20 CWH Added Timeline style

' 09/16/21 CWH Added clsSettings & crLogoPath

' Declarations

Const cRoutine As String = "Color"

Static dicColors As Object 'Color Dictionary

Static oLstWkb As Workbook 'Last Workbook

Static oSkin As ListObject 'Skin Table

Dim oStg As clsSettings 'Dactivate/Unprotect

Dim oLo As ListObject 'Current ListObject

Dim oLr As ListRow 'Current ListRow

Dim sKey As String 'Dictionary's Key

Dim sTyp As String 'Color Source Type

Dim sVal As String 'Color Source Value

Dim iRed As Integer 'Color's Red Component

Dim iGreen As Integer 'Color's Green Component

Dim iBlue As Integer 'Color's Blue Component

Dim lClr As Long 'Color Value

Dim v As Variant 'Generic Result

Const sDefaults As String = _

"Logo, T,Logo.gif; " & _

"Skin, P,Skin.jpg; " & _

"Form, C,3,3; " & _

"Frame, C,3,3; " & _

"Button, C,6,6; " & _

"Button Glow, C,7,7; " & _

"Dark, C,1,2; " & _

"Light, C,2,1; " & _

"Accent Dark, C,3,2; " & _

"Accent, C,4,4; " & _

"Accent Light, C,5,1; " & _

"TableStyle, T,*DefaultTableStyle;" & _

"PivotStyle, T,*DefaultPivotTableStyle;" & _

"SlicerStyle, T,*DefaultSlicerStyle;" & _

"TimelineStyle, T,*DefaultTimelineStyle;" & _

"Background, T,BackGround.jpg;" & _

"ChartStyle, T,201; " & _

"ChartColor, C,2,2; " & _

"ChartArea, T,ChartArea;" & _

"PlotArea, T,PlotArea; " & _

"Chart Title Location, T,Above; " & _

"Chart Legend Location, T,Right; " & _

"Logo Path, T,Logo.gif "

' Error Handling Initialization

On Error GoTo ErrHandler

Color = Null

' Check inputs and requisites

If oWorkbook Is Nothing Then Set oWorkbook = ActiveWorkbook

If ColorType = crReset Then Set oSkin = Nothing

If oSkin Is Nothing Then _

If Not Exists(Tables(oWorkbook), "Skin", oSkin) Then _

Exists Tables(ThisWorkbook), "Skin", oSkin

If oLstWkb Is Nothing Then Set oLstWkb = oWorkbook

' Initialize variables

If ColorType = crReset Then Set dicColors = Nothing

If dicColors Is Nothing Or oWorkbook.Name <> oLstWkb.Name Then

Set oStg = New clsSettings

Set oLstWkb = oWorkbook

Set dicColors = CreateObject("Scripting.Dictionary")

With oWorkbook

' Create default styles from sDefaults array

For Each v In Split(sDefaults, ";")

sKey = Trim(Split(v, ",")(0))

sTyp = Trim(Split(v, ",")(1))

sVal = Trim(Split(v, ",")(2))

Select Case sVal

Case Is = "*DefaultTableStyle": sVal = TblSty(oWorkbook, .DefaultTableStyle, "Table")

Case Is = "*DefaultPivotTableStyle": sVal = TblSty(oWorkbook, .DefaultPivotTableStyle, "Pivot")

Case Is = "*DefaultSlicerStyle": sVal = TblSty(oWorkbook, .DefaultSlicerStyle, "Slicer")

Case Is = "*DefaultTimelineStyle": sVal = TblSty(oWorkbook, .DefaultTimelineStyle, "Timeline")

End Select

Select Case sTyp

Case Is = "P" 'Picture

Set dicColors(sKey) = Nothing

If Not sVal Like "[A-Z]:*" And Not sVal Like "\\*" Then _

sVal = .Path & "\" & sVal

If Dir(sVal) <> vbNullString Then _

Set dicColors(sKey) = LoadPicture(sVal)

Case Is = "S" 'Style

dicColors(sKey) = .Styles(CLng(sVal)).Interior.Color

dicColors(sKey & ",Font") = .Styles(CLng(sVal)).Font.Color

Case Is = "C" 'Color

lClr = .Styles("Accent" & CLng(sVal)).Interior.Color

lClr = .Theme.ThemeColorScheme.Colors(CLng(sVal))

dicColors(sKey) = lClr

sVal = vbNullString: sVal = Split(v, ",")(3)

If sVal <> vbNullString Then

lClr = CLng(sVal)

Else

ColorCode2RGB lClr, iRed, iGreen, iBlue

lClr = IIf((iRed + iGreen + iBlue) / 3 < 128, 16777215, 0)

End If

dicColors(sKey & ",Font") = lClr

Case Is = "T" 'Text/Value

dicColors(sKey) = sVal

End Select

If Exists(Tables(oWorkbook), "Skin", oLo) Then

For Each oLr In oLo.ListRows

With GetFLD(oLr, "Format")

sKey = GetFLD(oLr, "Name")

sVal = Trim(.Text)

dicColors(sKey) = sVal

Select Case sKey

Case Is = "TableStyle"

If Exists(oWorkbook.TableStyles, sVal) Then _

oWorkbook.DefaultTableStyle = sVal

Case Is = "PivotStyle"

If Exists(oWorkbook.TableStyles, sVal) Then _

oWorkbook.DefaultPivotTableStyle = sVal

Case Is = "SlicerStyle"

If Exists(oWorkbook.TableStyles, sVal) Then _

oWorkbook.DefaultSlicerStyle = sVal

Case Is = "TimelineStyle"

If Exists(oWorkbook.TableStyles, sVal) Then _

oWorkbook.DefaultTimelineStyle = sVal

Case Is = "Logo"

If sVal Like "*.*" Then

If Not sVal Like "[A-Z]:*" And Not sVal Like "\\*" Then _

sVal = oWorkbook.Path & "\" & sVal

If Dir(sVal) <> vbNullString Then

dicColors("Logo Path") = sVal

Set dicColors(sKey) = LoadPicture(sVal)

End If

Else

dicColors(sKey) = .Interior.Color

End If

Case Else

Set v = GetFLD(oLr, "Number")

If Not v Is Nothing Then _

If v.Value = vbNullString Then Set v = Nothing

If sVal Like "*.*" And v Is Nothing Then

If Not sVal Like "[A-Z]:*" And Not sVal Like "\\*" Then _

sVal = oWorkbook.Path & "\" & sVal

If Dir(sVal) <> vbNullString Then _

Set dicColors(sKey) = LoadPicture(sVal) Else _

dicColors(sKey) = .Interior.Color

Else

dicColors(sKey) = .Interior.Color

End If

dicColors(sKey & ",Font") = .Font.Color

End Select

End With

End If

' Procedure

If ColorType <> crReset Then

If IsObject(dicColors.Items()(ColorType - 1)) Then _

Set Color = dicColors.Items()(ColorType - 1) Else _

Color = dicColors.Items()(ColorType - 1)

End If

ErrHandler:

Select Case Err.Number

Case Is = NoError: 'Do nothing

Case Is = 9: Resume Next 'Style not found

Case Is = 52, 75: Resume Next 'Illegal directory

Case Is = 1003, 1004: Resume Next 'Worksheet Protected

Case Is = -2147221080 'oLstWkb not yet set

Set oLstWkb = ActiveWorkbook

Resume

Case Else:

Select Case DspErrMsg(cModule & "." & cRoutine)

Case Is = vbAbort: Stop: Resume 'Debug mode - Trace

Case Is = vbRetry: Resume 'Try again

Case Is = vbIgnore: 'End routine

End Select

End Function

References:
DspErrMsg()
Exists()
Tables()
Dictionary Object