-
Aug 12th, 2020, 02:48 PM
#1
DwmGetColorizationColor - Close, but no cigar
I'm trying to find the active title bar colors under the last supported version of Windows. I want to ape them in controls, e.g. Label.
I am making several assumptions, any of which may be wrong.
Getting there but I am missing something and/or have faulty logic here:
Code:
Option Explicit
'
'Here I want to try to color Label1 as closely as possible to the Form's
'caption/title bar.
'
'I only really care about Windows 10 since everything else is now
'unsupported. However it still might be interesting to see how badly
'this fails on Windows 8.1 Fire Two or Windows 7 SP1.
'
Private Declare Function ColorRGBToHLS Lib "shlwapi" ( _
ByVal clrRGB As Long, _
ByRef wHue As Integer, _
ByRef wLuminance As Integer, _
ByRef wSaturation As Integer) As Long
Private Const S_OK As Long = 0
Private Declare Function DwmGetColorizationColor Lib "dwmapi" ( _
ByRef crColorization As Byte, _
ByRef fOpaqueBlend As Long) As Long
Private Sub GetTitleBarColors(ByRef BackColor As Long, ByRef ForeColor As Long)
Const MIN_BRIGHT_HUE As Integer = 30 'Orange.
Const MAX_BRIGHT_HUE As Integer = 122 'Dimming cyan.
Dim crColorization(0 To 3) As Byte 'ARGB.
Dim fOpaqueBlend As Long
Dim COLORREF(0 To 3) As Long '0BGR.
Dim wHue As Integer
Dim wLuminance As Integer
Dim wSaturation As Integer
If DwmGetColorizationColor(crColorization(0), fOpaqueBlend) = S_OK Then
'We'll ignore fOpaqueBlend because we will never
'be transparent against the desktop and covered
'windows: *** IS THIS CORRECT? ***
'ARGB to COLORREF blended with white: *** IS THIS CORRECT? ***
COLORREF(0) = Int(crColorization(2) * (CSng(&HFF&) / crColorization(3)))
COLORREF(1) = Int(crColorization(1) * (CSng(&HFF&) / crColorization(3)))
COLORREF(2) = Int(crColorization(0) * (CSng(&HFF&) / crColorization(3)))
If COLORREF(0) > &HFF& Then COLORREF(0) = &HFF&
If COLORREF(1) > &HFF& Then COLORREF(1) = &HFF&
If COLORREF(2) > &HFF& Then COLORREF(2) = &HFF&
BackColor = COLORREF(2) * &H10000 _
Or COLORREF(1) * &H100& _
Or COLORREF(0)
'Choose the proper contrasting ForeColor: *** IS THIS CORRECT? ***
ColorRGBToHLS BackColor, wHue, wLuminance, wSaturation
If wLuminance >= 240 \ 2 And MIN_BRIGHT_HUE <= wHue And wHue <= MAX_BRIGHT_HUE Then
ForeColor = vbBlack
Else
ForeColor = vbWhite
End If
Else
BackColor = vbInactiveTitleBar
ForeColor = vbInactiveTitleBarText
End If
End Sub
Private Sub Form_Load()
Dim BG As Long
Dim FG As Long
GetTitleBarColors BG, FG
With Label1
.BackColor = BG
.ForeColor = FG
End With
End Sub
No idea what this ends up looking like on downlevel Windows versions though.
-
Aug 12th, 2020, 02:54 PM
#2
Re: DwmGetColorizationColor - Close, but no cigar
BTW: This is Shell32's hue spectrum from 0 at left to 240 at right:
-
Aug 12th, 2020, 05:53 PM
#3
Re: DwmGetColorizationColor - Close, but no cigar
Even though imperfect, this might be good enough for my intended uses.
Of course the user might have made some other choice that makes this approach fall apart, for example a really bad choice of ForeColor against some BackColor.
The main thing I want this for is a docking capability for ToolWindow Forms in MDI Forms. Undocked, then docked:
There might be other reasons to derive these colors as well.
-
Aug 12th, 2020, 07:24 PM
#4
Re: DwmGetColorizationColor - Close, but no cigar
Well, I hate reaching directly into the registry but we don't seem to have any documented direct calls to get the right BackColor:
Code:
Option Explicit
'
'Here I want to try to color Label1 as closely as possible to the Form's
'caption/title bar.
'
'I only really care about Windows 10 since everything else is now
'unsupported. However it still might be interesting to see how badly
'this fails on Windows 8.1 Fire Two or Windows 7 SP1.
'
Private Declare Function ColorRGBToHLS Lib "shlwapi" ( _
ByVal clrRGB As Long, _
ByRef wHue As Integer, _
ByRef wLuminance As Integer, _
ByRef wSaturation As Integer) As Long
Private Const KEY_READ As Long = &H20019
Private Const ERROR_SUCCESS As Long = 0&
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExW" ( _
ByVal hKey As Long, _
ByVal lpSubKey As Long, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueExDWORD Lib "advapi32" _
Alias "RegQueryValueExW" ( _
ByVal hKey As Long, _
ByVal lpValueName As Long, _
ByVal lpReserved As Long, _
ByRef RegType As Long, _
ByRef Data As Long, _
ByRef cbData As Long) As Long
Private Sub GetTitleBarColors(ByRef BackColor As Long, ByRef ForeColor As Long)
Const HKEY_CURRENT_USER As Long = &H80000001
Const HKCU As Long = HKEY_CURRENT_USER
Const MIN_BRIGHT_HUE As Integer = 22 'Orange.
Const MAX_BRIGHT_HUE As Integer = 122 'Dimming cyan.
Dim hKey As Long
Dim RegType As Long
Dim cbData As Long
Dim wHue As Integer
Dim wLuminance As Integer
Dim wSaturation As Integer
Dim Success As Boolean
If RegOpenKeyEx(HKCU, _
StrPtr("SOFTWARE\Microsoft\Windows\DWM"), _
0, _
KEY_READ, _
hKey) = ERROR_SUCCESS Then
cbData = 4
If RegQueryValueExDWORD(hKey, _
StrPtr("AccentColor"), _
0, _
RegType, _
BackColor, _
cbData) = ERROR_SUCCESS Then
BackColor = BackColor And &HFFFFFF
'Choose the proper contrasting ForeColor: *** IS THIS CORRECT? ***
ColorRGBToHLS BackColor, wHue, wLuminance, wSaturation
If wLuminance >= 240 \ 2 And MIN_BRIGHT_HUE <= wHue And wHue <= MAX_BRIGHT_HUE Then
ForeColor = vbBlack
Else
ForeColor = vbWhite
End If
Success = True
End If
RegCloseKey hKey
End If
If Not Success Then
BackColor = vbInactiveTitleBar
ForeColor = vbInactiveTitleBarText
End If
End Sub
Private Sub Form_Load()
Dim BG As Long
Dim FG As Long
GetTitleBarColors BG, FG
With Label1
.BackColor = BG
.ForeColor = FG
End With
End Sub
I also fiddled with my "bright colors" hue range a bit for deciding whether to use black or white as ForeColor. Sadly that color setting doesn't seem to be in the registry.
-
Aug 13th, 2020, 03:35 AM
#5
Re: DwmGetColorizationColor - Close, but no cigar
FYI, here are a couple of helper functions I'm using for alpha blending and luminance calculation
Code:
Option Explicit
'
'Here I want to try to color Label1 as closely as possible to the Form's
'caption/title bar.
'
'I only really care about Windows 10 since everything else is now
'unsupported. However it still might be interesting to see how badly
'this fails on Windows 8.1 Fire Two or Windows 7 SP1.
'
Private Declare Function OleTranslateColor Lib "oleaut32" (ByVal lOleColor As Long, ByVal lHPalette As Long, pColorRef As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function ColorRGBToHLS Lib "shlwapi" ( _
ByVal clrRGB As Long, _
ByRef wHue As Integer, _
ByRef wLuminance As Integer, _
ByRef wSaturation As Integer) As Long
Private Const S_OK As Long = 0
Private Declare Function DwmGetColorizationColor Lib "dwmapi" ( _
ByRef crColorization As Byte, _
ByRef fOpaqueBlend As Long) As Long
Private Type RGB_QUAD
R As Byte
G As Byte
B As Byte
A As Byte
End Type
Private Sub GetTitleBarColors(ByRef BackColor As Long, ByRef ForeColor As Long)
Const MIN_BRIGHT_HUE As Integer = 30 'Orange.
Const MAX_BRIGHT_HUE As Integer = 122 'Dimming cyan.
Dim crColorization(0 To 3) As Byte 'ARGB.
Dim fOpaqueBlend As Long
Dim COLORREF(0 To 3) As Long '0BGR.
Dim wHue As Integer
Dim wLuminance As Integer
Dim wSaturation As Integer
If DwmGetColorizationColor(crColorization(0), fOpaqueBlend) = S_OK Then
'We'll ignore fOpaqueBlend because we will never
'be transparent against the desktop and covered
'windows: *** IS THIS CORRECT? ***
'ARGB to COLORREF blended with white: *** IS THIS CORRECT? ***
' COLORREF(0) = Int(crColorization(2) * (CSng(&HFF&) / crColorization(3)))
' COLORREF(1) = Int(crColorization(1) * (CSng(&HFF&) / crColorization(3)))
' COLORREF(2) = Int(crColorization(0) * (CSng(&HFF&) / crColorization(3)))
' If COLORREF(0) > &HFF& Then COLORREF(0) = &HFF&
' If COLORREF(1) > &HFF& Then COLORREF(1) = &HFF&
' If COLORREF(2) > &HFF& Then COLORREF(2) = &HFF&
' BackColor = COLORREF(2) * &H10000 _
' Or COLORREF(1) * &H100& _
' Or COLORREF(0)
BackColor = crColorization(0) * &H10000 _
Or crColorization(1) * &H100& _
Or crColorization(2)
BackColor = AlphaBlendColors(BackColor, vbWhite, crColorization(3))
'Choose the proper contrasting ForeColor: *** IS THIS CORRECT? ***
' ColorRGBToHLS BackColor, wHue, wLuminance, wSaturation
' If wLuminance >= 240 \ 2 And MIN_BRIGHT_HUE <= wHue And wHue <= MAX_BRIGHT_HUE Then
' ForeColor = vbBlack
' Else
' ForeColor = vbWhite
' End If
If GetLuminance(BackColor) < GetLuminance(vbButtonFace) Then
ForeColor = vbBlack
Else
ForeColor = vbWhite
End If
Else
BackColor = vbInactiveTitleBar
ForeColor = vbInactiveTitleBarText
End If
End Sub
Private Sub Form_Load()
Dim BG As Long
Dim FG As Long
GetTitleBarColors BG, FG
With Label1
.BackColor = BG
.ForeColor = FG
End With
End Sub
Public Function AlphaBlendColors(ByVal clrFirst As OLE_COLOR, ByVal clrSecond As OLE_COLOR, ByVal lAlpha As Long) As Long
Dim uFore As RGB_QUAD
Dim uBack As RGB_QUAD
Call OleTranslateColor(clrFirst, 0, uFore)
Call OleTranslateColor(clrSecond, 0, uBack)
With uFore
.R = (.R * lAlpha + uBack.R * (255 - lAlpha)) / 255
.G = (.G * lAlpha + uBack.G * (255 - lAlpha)) / 255
.B = (.B * lAlpha + uBack.B * (255 - lAlpha)) / 255
End With
Call CopyMemory(AlphaBlendColors, uFore, 4)
End Function
Public Function GetLuminance(ByVal clrColor As OLE_COLOR) As Long
Dim uColor As RGB_QUAD
Call OleTranslateColor(clrColor, 0, uColor)
GetLuminance = (uColor.R * 76& + uColor.G * 150& + uColor.B * 29&) / 255
End Function
With OleTranslateColor can target arrays for the result and skip UDT declartion of RGB_QUAD altogether I guess.
cheers,
</wqw>
Last edited by wqweto; Aug 13th, 2020 at 03:43 AM.
-
Aug 13th, 2020, 07:49 AM
#6
Re: DwmGetColorizationColor - Close, but no cigar
Yeah, those should be RGBQUAD not COLORREF as I named them. That was an error.
Fishing "AccentColor" out of the registry seems to work though. The only challenge left is choosing the ForeColor that matches the window Title Bar color.
-
Aug 14th, 2020, 01:50 PM
#7
Re: DwmGetColorizationColor - Close, but no cigar
hi I remember dealing with the same thing years ago and couldn't find a way to get the correct colors with DwmGetColorizationColor and finished using the registry.
I also used invert the color between black and white to contrast, this function works for me
Code:
Private Function IsDarkColor(ByVal Color As Long) As Boolean
Dim BGRA(0 To 3) As Byte
OleTranslateColor Color, 0, BGRA(0)'ByRef As Any
IsDarkColor = ((CLng(BGRA(0)) + (CLng(BGRA(1) * 3)) + CLng(BGRA(2))) / 2) < 382
End Function
-
Aug 14th, 2020, 04:05 PM
#8
Re: DwmGetColorizationColor - Close, but no cigar
Thanks. Looks good enough to me.
Only needed rarely anyhow, but still seems like an odd thing to be hard to get.
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|