I'm using the correct code (there's no actual code in part 1's
QuerySchemeColor).
I thnk I'm calling HSLtoRGB correctly, with 4 arguments:
HSLtoRGB RGB(79,129,189),0,0,.25
Why would "RGB(79,129,189)" return 0? Shouldn't RGB(79,129,189) return the
long RGB value of "R79, G129, B189"?
In any case below is a copy of the code I'm using. The only modifications
I've made to your posted code are as follows:
In Colours2 I added "Call QuerySchemeColor(HexString)" to Case FF and
commented out the messagebox line in that case. That added line is a copy
and paste of your code at Case D4 To DF.
In QuerySchemeColour I added the following lines at the end. I only did
this because it seems that HSLtoRGB isn't recognising the function RGB as a
valid first argument - I figured I'd try passing a long value as the first
argument to see if I got any different results.Dim lngr As Long
Dim lngg As Long
Dim lngb As Long
Dim lngrgb As Long
lngr = CLng("&H" & Mid$(ThemeColorHex, 7, 2))
lngg = CLng("&H" & Mid$(ThemeColorHex, 5, 2))
lngb = CLng("&H" & Mid$(ThemeColorHex, 3, 2))
lngrgb = RGB(lngr, lngg, lngb)
HSLtoRGB lngrgb, 0, 0, 0.25
<<
In HSLtoRGB I added "MsgBox RGB" to the end to display the RGB value that
that macro ends up with. (Can I make a suggestion? Isn't RGB the name of a
VB function? You might want to change the name of that variable.)
No matter what selection I run Colours2 from, HSLtoRGB returns "4210752".
From the following code can you see what I'm doing wrong?
Thanks again, code follows...
Sub Colours2()
Dim HexString As String
HexString = Right$(String$(7, "0") & Hex$(Selection.Font.Color), 8)
Select Case Left$(HexString, 2)
Case "00"
If HexString = "00C8C67F" Then
MsgBox "The colour of the Selection is not all the same"
Else
MsgBox "The colour is an RGB value:" & vbCr & _
"Red: " & _
CLng("&H" & Mid$(HexString, 7, 2)) & vbCr & _
"Green: " & _
CLng("&H" & Mid$(HexString, 5, 2)) & vbCr & _
"Blue: " & _
CLng("&H" & Mid$(HexString, 3, 2))
End If
Case "FF"
'ADDED CODE
Call QuerySchemeColor(HexString)
'END ADDED CODE
'MsgBox "The colour is set to the default of 'Automatic'"
Case "80"
MsgBox "The colour is an OLE Color"
Case "D4" To "DF"
Call QuerySchemeColor(HexString)
Case Else
MsgBox "The colour is of an unknown type." & vbCr & _
"The code is: 0x" & HexString
End Select
End Sub
Sub QuerySchemeColor(HexString As String)
Dim SchemeColorByte As String
Dim ZeroByte As String
Dim DarknessByte As String
Dim LightnessByte As String
Dim SchemeColor As Long
Dim Darkness As Long
Dim Lightness As Long
Dim SchemeColorName As String
Dim TintingAndShading As String
SchemeColorByte = Mid$(HexString, 1, 2)
ZeroByte = Mid$(HexString, 3, 2)
DarknessByte = Mid$(HexString, 5, 2)
LightnessByte = Mid$(HexString, 7, 2)
SchemeColor = "&H" & Right$(SchemeColorByte, 1)
' New variables
Dim ThemeColor As MsoThemeColorSchemeIndex
Dim ThemeColorRGB As Long
Dim ThemeColorHex As String
' Changed translation, now to theme colour scheme index
Select Case SchemeColor
Case wdThemeColorMainDark1: ThemeColor = msoThemeDark1
Case wdThemeColorMainLight1: ThemeColor = msoThemeLight1
Case wdThemeColorMainDark2: ThemeColor = msoThemeDark2
Case wdThemeColorMainLight2: ThemeColor = msoThemeLight2
Case wdThemeColorAccent1: ThemeColor = msoThemeAccent1
Case wdThemeColorAccent2: ThemeColor = msoThemeAccent2
Case wdThemeColorAccent3: ThemeColor = msoThemeAccent3
Case wdThemeColorAccent4: ThemeColor = msoThemeAccent4
Case wdThemeColorAccent5: ThemeColor = msoThemeAccent5
Case wdThemeColorAccent6: ThemeColor = msoThemeAccent6
Case wdThemeColorHyperlink: ThemeColor = msoThemeHyperlink
Case wdThemeColorHyperlinkFollowed:
ThemeColor = msoThemeFollowedHyperlink
Case wdThemeColorBackground1: ThemeColor = msoThemeLight1
Case wdThemeColorText1: ThemeColor = msoThemeDark1
Case wdThemeColorBackground2: ThemeColor = msoThemeLight2
Case wdThemeColorText2: ThemeColor = msoThemeDark2
Case Else: ' This shouldn't really ever happen
End Select
' Pick up the RGB and translate to a hex string
ThemeColorRGB = _
ActiveDocument.DocumentTheme.ThemeColorScheme(ThemeColor).RGB
ThemeColorHex = Right$(String$(7, "0") & Hex$(ThemeColorRGB), 8)
Lightness = 100 - ("&H" & LightnessByte) / &HFF * 100
Darkness = 100 - ("&H" & DarknessByte) / &HFF * 100
If Lightness = 0 Then
If Darkness = 0 Then
TintingAndShading = ""
Else
TintingAndShading = ", Darker " & Darkness & "%"
End If
Else
TintingAndShading = ", Lighter " & Lightness & "%"
End If
'ADDED CODE
Dim lngr As Long
Dim lngg As Long
Dim lngb As Long
Dim lngrgb As Long
lngr = CLng("&H" & Mid$(ThemeColorHex, 7, 2))
lngg = CLng("&H" & Mid$(ThemeColorHex, 5, 2))
lngb = CLng("&H" & Mid$(ThemeColorHex, 3, 2))
lngrgb = RGB(lngr, lngg, lngb)
HSLtoRGB lngrgb, 0, 0, 0.25
'END ADDED CODE
' Display the colour instead of the scheme name
MsgBox "The colour is: " & _
"Red: " & CLng("&H" & Mid$(ThemeColorHex, 7, 2)) & _
", Green: " & CLng("&H" & Mid$(ThemeColorHex, 5, 2)) & _
", Blue: " & CLng("&H" & Mid$(ThemeColorHex, 3, 2)) & _
TintingAndShading
End Sub
Sub HSLtoRGB(RGB As Long, H As Double, S As Double, L As Double)
Dim R As Double
Dim G As Double
Dim B As Double
Dim HR As Double
Dim HG As Double
Dim HB As Double
Dim X As Double
Dim Y As Double
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
HR = IIf(H > 2 / 3, H - 2 / 3, H + 1 / 3)
HG = H
HB = IIf(H < 1 / 3, H + 2 / 3, H - 1 / 3)
R = H2C(X, Y, HR)
G = H2C(X, Y, HG)
B = H2C(X, Y, HB)
End If
RGB = CLng("&H00" & _
Right$("0" & Hex$(Round(B * 255)), 2) & _
Right$("0" & Hex$(Round(G * 255)), 2) & _
Right$("0" & Hex$(Round(R * 255)), 2))
'ADDED CODE
MsgBox RGB
'returns 4210752
End Sub
"