Embedded Files
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
Next
' Create Styles from Skin table
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
Next
End If
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 Select
End Function
References:
DspErrMsg()
Exists()
Tables()
Dictionary Object
Page updated
Google Sites
Report abuse