How to Find RGB for word theme colors

[gmkrishna]

Hi all,

Could any can help me to find out the RGB value for theme colors. I am using "Selection.Font.color" to get the long value and convert into Hex and Hex to RGB.

This works fine if the text is one of the standard colors OR even a custom color from the RGB color-picker, but it will return nagative long value -738148353 if the text color is one of those in the "theme colors" in Font Color dialog.

Find the attachement below.
21450

[gmayor]

Download ColorCop (http://colorcop.net/). It will give you the RGB/Hex values of any colour on screen. Set the mode to Visual Basic Hex.

[gmkrishna]

Unfortunately I don’t have privilege to use anytools. So I need to build a code.

[macropod]

The coding for this is quite involved. See, for example: www.wordarticles.com/Articles/Colours/2007BuildSet.php

[gmayor]

A company that doesn't allow its employees to use simple tools that enable them to do their job, but allows them to use VBA with which they could wreak no end of damage, really needs to review its security policies. I would strongly urge you to get your IT department to install the software I suggested, or if, as I suspect, some jobsworth there will refuse your request, take it up with management. IT support is supposed to help you do your job, not get in the way of doing it. If I had to work with colours (as I do) I wouldn't be without this simple tool.

[macropod]

Hi Graham,


I agree with your sentiments. However, the question to be answered is whether the OP needs the displayed RGB values or the nominal RGB values for theme colors. Simply changing the theme changes the displayed colours but the nominal RGB values remain the same.



Hence, the displayed RGB values of any colour on screen are not necessarily the same as the nominal RGB values for theme colors and, as the OP notes, the RGB values have extra content when a them is applied. See the discussion at: https://social.msdn.microsoft.com/Forums/office/en-US/2ea570b5-ce3a-4f37-a37c-9b2100941d39/how-to-find-shading-in-word-document-using-color-number-reciving-from-wordopenxml?forum=worddev.

[gmkrishna]

So, we could not find the ture RGB value for theme colors using macro?

[macropod]

See my reply in post #4.

[gmkrishna]

Yes, that link showing what is theme color but I know this already well. But, I need a solution to get the RGB value for theme color.

[gmaxey]

It took me awhile to locate this, at some point after Tony published his article, I adapted one of his functions to report color detail: Try:


Option Explicit
Private Enum ColourType
ColourTypeRGB = &H0
ColourTypeAutomatic = &HFF
ColourTypeSystem = &H80
ColourTypeThemeLow = &HD0
ColourTypeThemeHigh = &HDF
End Enum
Private Type ColourDetails
ColourType As ColourType
ThemeColorIndex As WdThemeColorIndex
TintAndShade As Double
RGB As Long
End Type
Private Type HSL
H As Double ' Range 0 - 1
S As Double ' Range 0 - 1
L As Double ' Range 0 - 1
End Type

'Everything above this point is pure Tony Jollans http://www.wordarticles.com/Articles/Colours/2007.php#SettingColours
Sub ApplyThemeColors()
Selection.Font.Color = GetThemeColor(ThemeColorIndex:=wdThemeColorAccent2, _
TintAndShade:=0.5)
lbl_Exit:
Exit Sub
End Sub
Sub DemoGetColorDetails()
MsgBox fcnColorDetails(Selection.Range)
End Sub
Function fcnColorDetails(Optional oRng As Range, Optional oCtrl As Object = Nothing) As String
'Adapted by Gregory K. Maxey from code by Tony Jollans http://www.wordarticles.com/Articles/Colours/2007.php#SettingColours
'Use this macro to return color details from selected text.
Dim lngColor As Long
Dim ColourToTestHex As String
If oCtrl Is Nothing Then
lngColor = oRng.Font.Color
Else
lngColor = oCtrl.ForeColor
End If
If Not lngColor = 9999999 Then
With QueryColour(lngColor)
Select Case .ColourType
Case ColourTypeRGB
fcnColorDetails = "Non-theme color." & vbCr _
& "Basic long color = " & lngColor & vbCr _
& "RGB(" & (lngColor And &HFF&) _
& ", " & (lngColor And &HFF00&) / &H100& _
& ", " & (lngColor And &HFF0000) / &H10000 & ")"
Case ColourTypeAutomatic
fcnColorDetails = "Automatic contrasting color." & vbCr _
& "Long color returned = " & lngColor & vbCr _
& "Basic long color = " & CLng((lngColor And &HFF0000) / &H10000) _
* 65536 + CLng((lngColor And &HFF00&) / &H100&) _
* 256 + CLng(lngColor And &HFF&) & vbCr _
& "RGB(" & (lngColor And &HFF&) & ", " _
& (lngColor And &HFF00&) / &H100& & ", " _
& (lngColor And &HFF0000) / &H10000 & ")"
Case ColourTypeSystem
fcnColorDetails = "System color"
Case ColourTypeThemeLow
fcnColorDetails = "Theme color: " & ThemeColorName(.ThemeColorIndex) _
& TintAndShadeText(.TintAndShade) & vbCr _
& "Basic long color = " & RGB((.RGB And &HFF&), _
(.RGB And &HFF00&) / &H100&, _
(.RGB And &HFF0000) / &H10000) & vbCr _
& "RGB(" & (.RGB And &HFF&) & ", " _
& (.RGB And &HFF00&) / &H100& & ", " _
& (.RGB And &HFF0000) / &H10000 & ")"
Case Else
fcnColorDetails = "Unrecognized format."
End Select
End With
Else
fcnColorDetails = "Color cannot be determined as the selected text contains multiple colors." & vbCr + vbCr _
& "Select a single color and try again."
End If
lbl_Exit:
Exit Function
End Function
'Everything below this point is pure Tony Jollans http://www.wordarticles.com/Articles/Colours/2007.php#SettingColours
Function GetThemeColor(ThemeColorIndex As WdThemeColorIndex, TintAndShade As Double) As Long
Const HexadecimalPrefix As String = "&H"
Const UseThemeColor As String = "D"
Const UnusedZeroByte As String = "00"
Const Unchanged As String = "FF"
Dim ThemeColor As String
Dim LightnessOrDarkness As String
ThemeColor = Hex$(ThemeColorIndex)
If TintAndShade >= 0 Then
LightnessOrDarkness = Unchanged & Right$("0" & Hex$((1 - TintAndShade) * &HFF), 2)
Else
LightnessOrDarkness = Right$("0" & Hex$((1 + TintAndShade) * &HFF), 2) & Unchanged
End If
GetThemeColor = CLng(HexadecimalPrefix & UseThemeColor & _
ThemeColor & UnusedZeroByte & _
LightnessOrDarkness)
lbl_Exit:
Exit Function
End Function
Private Function QueryColour(ColourToTest As Long) As ColourDetails
Dim ColourToTestHex As String
Dim ColourTypeByte As Byte
ColourToTestHex = Right$(String$(7, "0") & Hex$(ColourToTest), 8)
ColourTypeByte = CByte("&H" & Left$(ColourToTestHex, 2))
Select Case ColourTypeByte
Case ColourTypeRGB
QueryColour.ColourType = ColourTypeRGB
Case ColourTypeAutomatic
QueryColour.ColourType = ColourTypeAutomatic
Case ColourTypeSystem
QueryColour.ColourType = ColourTypeSystem
Case ColourTypeThemeLow To ColourTypeThemeHigh
QueryColour = QueryThemeColor(ColourTypeByte, ColourToTestHex)
Case Else
QueryColour.ColourType = ColourTypeByte
End Select
End Function

Private Function QueryThemeColor(ColourTypeByte As Byte, _
ColourToTestHex As String) As ColourDetails
Const Unchanged As Byte = &HFF
Dim LightnessByte As Byte
Dim DarknessByte As Byte

LightnessByte = CByte("&H" & Mid$(ColourToTestHex, 7, 2))
DarknessByte = CByte("&H" & Mid$(ColourToTestHex, 5, 2))
QueryThemeColor.ColourType = ColourTypeByte And &HF0
QueryThemeColor.ThemeColorIndex = ColourTypeByte And &HF
If DarknessByte <> Unchanged Then
QueryThemeColor.TintAndShade = Round(-1 + DarknessByte / &HFF, 2)
End If
If LightnessByte <> Unchanged Then
QueryThemeColor.TintAndShade = Round(1 - LightnessByte / &HFF, 2)
End If
QueryThemeColor.RGB = GetRGB(QueryThemeColor.ThemeColorIndex, QueryThemeColor.TintAndShade)
End Function

Private Function GetRGB(ThemeColorIndex As WdThemeColorIndex, TintAndShade As Double) As String
Dim ColorSchemeIndex As MsoThemeColorSchemeIndex
Dim ColorSchemeRGB As Long
Dim ColorSchemeHSL As HSL
Dim TintedAndShadedRGB As Long
ColorSchemeIndex = ThemeColorSchemeIndex(ThemeColorIndex)
ColorSchemeRGB = ActiveDocument.DocumentTheme.ThemeColorScheme(ColorSchemeIndex).RGB
ColorSchemeHSL = RGBtoHSL(ColorSchemeRGB)
ColorSchemeHSL.L = (ColorSchemeHSL.L * (Abs(TintAndShade))) + _
(Abs(TintAndShade > 0) * (1 - TintAndShade))
TintedAndShadedRGB = HSLtoRGB(ColorSchemeHSL)
GetRGB = TintedAndShadedRGB
End Function

Private Function ThemeColorSchemeIndex(ThemeColorIndex As WdThemeColorIndex) As MsoThemeColorSchemeIndex
Select Case ThemeColorIndex
Case wdThemeColorMainDark1: ThemeColorSchemeIndex = msoThemeDark1
Case wdThemeColorMainLight1: ThemeColorSchemeIndex = msoThemeLight1
Case wdThemeColorMainDark2: ThemeColorSchemeIndex = msoThemeDark2
Case wdThemeColorMainLight2: ThemeColorSchemeIndex = msoThemeLight2
Case wdThemeColorAccent1: ThemeColorSchemeIndex = msoThemeAccent1
Case wdThemeColorAccent2: ThemeColorSchemeIndex = msoThemeAccent2
Case wdThemeColorAccent3: ThemeColorSchemeIndex = msoThemeAccent3
Case wdThemeColorAccent4: ThemeColorSchemeIndex = msoThemeAccent4
Case wdThemeColorAccent5: ThemeColorSchemeIndex = msoThemeAccent5
Case wdThemeColorAccent6: ThemeColorSchemeIndex = msoThemeAccent6
Case wdThemeColorHyperlink: ThemeColorSchemeIndex = msoThemeHyperlink
Case wdThemeColorHyperlinkFollowed: ThemeColorSchemeIndex = msoThemeFollowedHyperlink
Case wdThemeColorBackground1: ThemeColorSchemeIndex = msoThemeLight1
Case wdThemeColorText1: ThemeColorSchemeIndex = msoThemeDark1
Case wdThemeColorBackground2: ThemeColorSchemeIndex = msoThemeLight2
Case wdThemeColorText2: ThemeColorSchemeIndex = msoThemeDark2
Case Else: ' This shouldn't really ever happen
End Select
End Function

Private Function RGBtoHSL(RGB As Long) As HSL
Dim R As Double ' Range 0 ? 1
Dim G As Double ' Range 0 ? 1
Dim B As Double ' Range 0 ? 1
Dim RGB_Max As Double
Dim RGB_Min As Double
Dim RGB_Diff As Double
Dim HexString As String
HexString = Right$(String$(7, "0") & Hex$(RGB), 8)
R = CDbl("&H" & Mid$(HexString, 7, 2)) / 255
G = CDbl("&H" & Mid$(HexString, 5, 2)) / 255
B = CDbl("&H" & Mid$(HexString, 3, 2)) / 255
RGB_Max = R
If G > RGB_Max Then RGB_Max = G
If B > RGB_Max Then RGB_Max = B
RGB_Min = R
If G < RGB_Min Then RGB_Min = G
If B < RGB_Min Then RGB_Min = B
RGB_Diff = RGB_Max - RGB_Min
With RGBtoHSL
.L = (RGB_Max + RGB_Min) / 2
If RGB_Diff = 0 Then
.S = 0
.H = 0
Else
Select Case RGB_Max
Case R: .H = (1 / 6) * (G - B) / RGB_Diff - (B > G)
Case G: .H = (1 / 6) * (B - R) / RGB_Diff + (1 / 3)
Case B: .H = (1 / 6) * (R - G) / RGB_Diff + (2 / 3)
End Select
Select Case .L
Case Is < 0.5: .S = RGB_Diff / (2 * .L)
Case Else: .S = RGB_Diff / (2 - (2 * .L))
End Select
End If
End With
End Function

Private Function HSLtoRGB(HSL As HSL) As Long
Dim R As Double
Dim G As Double
Dim B As Double
Dim X As Double
Dim Y As Double
With HSL
If .S = 0 Then
R = .L
G = .L
B = .L
Else
Select Case .L
Case Is < 0.5: X = .L * (1 + .S)
Case Else: X = .L + .S - (.L * .S)
End Select
Y = 2 * .L - X
R = H2C(X, Y, IIf(.H > 2 / 3, .H - 2 / 3, .H + 1 / 3))
G = H2C(X, Y, .H)
B = H2C(X, Y, IIf(.H < 1 / 3, .H + 2 / 3, .H - 1 / 3))
End If
End With
HSLtoRGB = CLng("&H00" & _
Right$("0" & Hex$(Round(B * 255)), 2) & _
Right$("0" & Hex$(Round(G * 255)), 2) & _
Right$("0" & Hex$(Round(R * 255)), 2))
End Function

Private Function H2C(X As Double, Y As Double, HC As Double) As Double
Select Case HC
Case Is < 1 / 6: H2C = Y + ((X - Y) * 6 * HC)
Case Is < 1 / 2: H2C = X
Case Is < 2 / 3: H2C = Y + ((X - Y) * ((2 / 3) - HC) * 6)
Case Else: H2C = Y
End Select
End Function

Function ThemeColorName(ThemeColorIndex As WdThemeColorIndex, Optional LanguageId As MsoLanguageID) As String
If LanguageId = 0 Then
LanguageId = LanguageSettings.LanguageId(msoLanguageIDUI)
End If
Select Case LanguageId
Case msoLanguageIDDutch
Select Case ThemeColorIndex
Case wdThemeColorMainDark1: ThemeColorName = "Donker 1"
Case wdThemeColorMainLight1: ThemeColorName = "Licht 1"
Case wdThemeColorMainDark2: ThemeColorName = "Donker 2"
Case wdThemeColorMainLight2: ThemeColorName = "Licht 2"
Case wdThemeColorAccent1: ThemeColorName = "Accent 1"
Case wdThemeColorAccent2: ThemeColorName = "Accent 2"
Case wdThemeColorAccent3: ThemeColorName = "Accent 3"
Case wdThemeColorAccent4: ThemeColorName = "Accent 4"
Case wdThemeColorAccent5: ThemeColorName = "Accent 5"
Case wdThemeColorAccent6: ThemeColorName = "Accent 6"
Case wdThemeColorHyperlink: ThemeColorName = "Hyperlink"
Case wdThemeColorHyperlinkFollowed: ThemeColorName = "Gevolgde Hyperlink"
Case wdThemeColorBackground1: ThemeColorName = "Achtergrond 1"
Case wdThemeColorText1: ThemeColorName = "Tekst 1"
Case wdThemeColorBackground2: ThemeColorName = "Achtergrond 2"
Case wdThemeColorText2: ThemeColorName = "Tekst 2"
Case Else: ThemeColorName = "Onbekent " & ThemeColorIndex
End Select
Case msoLanguageIDFrench
Select Case ThemeColorIndex
Case wdThemeColorMainDark1: ThemeColorName = "Sombre 1"
Case wdThemeColorMainLight1: ThemeColorName = "Clair 1"
Case wdThemeColorMainDark2: ThemeColorName = "Sombre 2"
Case wdThemeColorMainLight2: ThemeColorName = "Clair 2"
Case wdThemeColorAccent1: ThemeColorName = "Accentuation 1"
Case wdThemeColorAccent2: ThemeColorName = "Accentuation 2"
Case wdThemeColorAccent3: ThemeColorName = "Accentuation 3"
Case wdThemeColorAccent4: ThemeColorName = "Accentuation 4"
Case wdThemeColorAccent5: ThemeColorName = "Accentuation 5"
Case wdThemeColorAccent6: ThemeColorName = "Accentuation 6"
Case wdThemeColorHyperlink: ThemeColorName = "Lien hypertexte"
Case wdThemeColorHyperlinkFollowed: ThemeColorName = "Lien hypertexte visit?"
Case wdThemeColorBackground1: ThemeColorName = "Arri?re-plan 1"
Case wdThemeColorText1: ThemeColorName = "Texte 1"
Case wdThemeColorBackground2: ThemeColorName = "Arri?re-plan 2"
Case wdThemeColorText2: ThemeColorName = "Texte 2"
Case Else: ThemeColorName = "Inconnu " & ThemeColorIndex
End Select
Case Else ' msoLanguageIDEnglishUS
Select Case ThemeColorIndex
Case wdThemeColorMainDark1: ThemeColorName = "Dark 1"
Case wdThemeColorMainLight1: ThemeColorName = "Light 1"
Case wdThemeColorMainDark2: ThemeColorName = "Dark 2"
Case wdThemeColorMainLight2: ThemeColorName = "Light 2"
Case wdThemeColorAccent1: ThemeColorName = "Accent 1"
Case wdThemeColorAccent2: ThemeColorName = "Accent 2"
Case wdThemeColorAccent3: ThemeColorName = "Accent 3"
Case wdThemeColorAccent4: ThemeColorName = "Accent 4"
Case wdThemeColorAccent5: ThemeColorName = "Accent 5"
Case wdThemeColorAccent6: ThemeColorName = "Accent 6"
Case wdThemeColorHyperlink: ThemeColorName = "Hyperlink"
Case wdThemeColorHyperlinkFollowed: ThemeColorName = "Followed Hyperlink"
Case wdThemeColorBackground1: ThemeColorName = "Background 1"
Case wdThemeColorText1: ThemeColorName = "Text 1"
Case wdThemeColorBackground2: ThemeColorName = "Background 2"
Case wdThemeColorText2: ThemeColorName = "Text 2"
Case Else: ThemeColorName = "Unknown " & ThemeColorIndex
End Select
End Select
End Function

Function TintAndShadeText(TintAndShade As Double, Optional LanguageId As MsoLanguageID) As String
If LanguageId = 0 Then
LanguageId = LanguageSettings.LanguageId(msoLanguageIDUI)
End If
Select Case TintAndShade
Case 0: TintAndShadeText = ""
Case Is > 0
Select Case LanguageId
Case msoLanguageIDDutch: TintAndShadeText = ", lichter "
Case msoLanguageIDFrench: TintAndShadeText = ", plus clair "
Case Else: TintAndShadeText = ", lighter "
End Select
TintAndShadeText = TintAndShadeText & TintAndShade * 100 & "%"
Case Is < 0
Select Case LanguageId
Case msoLanguageIDDutch: TintAndShadeText = ", donkerder "
Case msoLanguageIDFrench: TintAndShadeText = ", plus sombre "
Case Else: TintAndShadeText = ", darker "
End Select
TintAndShadeText = TintAndShadeText & TintAndShade * -100 & "%"
End Select
End Function