Using WinAPI to change the color on the title bar of a UserForm

[abdelfattah]

hello
I search for highlight the title bar of a UserForm .
I have this code should highlight red ,but it doesn't

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function SetSysColors Lib "user32" (ByVal nChanges As Long, lpSysColor As Long, lpColorValues As Long) As Long
Private originalColor As Long
Private Sub UserForm_Activate()
  originalColor = GetSysColor(2)
  Call SetSysColors(1, 2, RGB(255, 0, 0))  'RGB(255,0,0) = RED
End Sub
Private Sub UserForm_Terminate()
  Call SetSysColors(1, 2, originalColor)
End Sub

any solution experts ?

 

[Jaafar Tribak]

how can I make back color for the form is same color for the titl bar .

Hi guys,

From my personal experience, if Windows is themed, it is not easy to get the actual colors of the UI elements. I have had little success with GetSysColor, GetThemeColor, GetThemeSysColorBrush ...etc.

If all you want is to give the userfom the same color as its titlebar, you can cheat by reading the color of a pixel from the caption area. This is an inelegant hack but it is easy and it works regardless of the current applied themes if any.

Option Explicit

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#Else
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#End If

Private Function GetCaptionColor(ByVal Form As MSForms.UserForm) As Long
    Const SM_CYCAPTION = 4
    #If Win64 Then
        Dim hwnd As LongLong, hdc As LongLong
    #Else
        Dim hwnd As Long, hdc As Long
    #End If
    Dim tWinRect As RECT

    Call IUnknown_GetWindow(Form, VarPtr(hwnd))
    hdc = GetDC(0)
    Call GetWindowRect(hwnd, tWinRect)
    With tWinRect
        GetCaptionColor = GetPixel(hdc, .Left + (.Right - .Left) / 2, .Top + GetSystemMetrics(SM_CYCAPTION) - 1)
    End With
    Call ReleaseDC(0, hdc)
End Function

Private Sub UserForm_Initialize()
    Me.BackColor = GetCaptionColor(Me)
End Sub

 

[abdelfattah]

Also, quick question - do you know if you use 32bit Excel or 64bit Excel?

64bit Exce

 

[abdelfattah]

@Jaafar Tribak

I'm glad to share us your idea . actually your code works just in original color , if I select another color like red it will return to original color for the userform

any way thanks for your trying

 

[Dan_W]

64bit Exce

Well, with this piece of information I can say with confidence that the code you posted above was never going to work - because those API Declarations will only work for 32bit Excel.
As I pointed out the other day, and as Jaafar has since confirmed, you're not going to find much help from SetSysColors. For completeness, I nonetheless set out below the code updated for 64bit on the off-chance that either you or someone else might have need of it:

Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetSysColors Lib "user32" (ByVal nChanges As Long, lpSysColor As Long, lpColorValues As Long) As Long
Private originalColor As Long
Private Sub UserForm_Activate()
  originalColor = GetSysColor(2)
  Call SetSysColors(1, 2, RGB(255, 0, 0))  'RGB(255,0,0) = RED
End Sub
Private Sub UserForm_Terminate()
  Call SetSysColors(1, 2, originalColor)
End Sub

In fact, I'm surprised you didn't get an error message from VBA when you tried to run the code...?

 

[Dan_W]

I set out below the code for the solution I proposed the other day. It is not as sophisticated as the project uploaded by @Jaafar Tribak, and it's a bit longer than I had originally anticipated, but I have structured the code so that it should sit in a single class module that you can then import into your workbook/project and use to apply to any userform with just a few lines of code.

I have prepared three demo userforms to show the various customisations available, and have provided a brief explanation of the how to use the class in the comments of one of the modules.

Download demo workbook

@abdelfattah, @Jaafar Tribak - as always, feedback is encouraged and always appreciated.

I expect that there will possibly be some bugs in the code or adjustments that need to be made, but I thought I ought to upload it now for you to try it out because I'm conscious that I had said I would get it done this weekend.

To test the code, add the Sample Userform Code below to an empty userform, and then the cCustomUserForm.cls code into a class module named cCustomUserform, and then load the userform as normal.

Sample Userform Code

Private CustomForm As New cCustomUserform

Private Sub UserForm_Initialize()
  
    CustomForm.TitleBarColor = RGB(120, 0, 0)
    Set CustomForm.Form = Me

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

    Set CustomForm = Nothing

End Sub

cCustomUserform.cls

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As Long
        Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long
    #Else
        Private Declare PtrSafe Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
        Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long
    #End If
  
    Private Declare PtrSafe Function ColorAdjustLuma Lib "SHLWAPI.DLL" (ByVal clrRGB As Long, ByVal n As Long, ByVal fScale As Long) As Long
    Private Declare PtrSafe Function DrawMenuBar Lib "user32.dll" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function GetClassLong Lib "user32.dll" Alias "GetClassLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
    Private Declare PtrSafe Function OleTranslateColor Lib "oleAut32.dll" (ByVal clr As OLE_COLOR, ByVal palet As LongPtr, col As Long) As Long
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Function ReleaseCapture Lib "user32.dll" () As Long
    Private Declare PtrSafe Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
    Private Declare PtrSafe Function SetClassLong Lib "user32.dll" Alias "SetClassLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  
    Private hWnd                                    As LongPtr
    Private WindowStyle                             As LongPtr
  
#Else
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA " (ByVal hwnd As Long , ByVal nIndex As Long, ByVal dwNewLong As Long ) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

    Private Declare Function ColorAdjustLuma Lib "SHLWAPI.DLL" (ByVal clrRGB As Long, ByVal n As Long, ByVal fScale As Long) As Long
    Private Declare Function DrawMenuBar Lib "user32.dll" (ByVal hWnd As Long) As Long
    Private Declare Function GetClassLong Lib "user32.dll" Alias "GetClassLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
    Private Declare Function OleTranslateColor Lib "oleAut32.dll" (ByVal clr As OLE_COLOR, ByVal palet As Long, col As Long) As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function ReleaseCapture Lib "user32.dll" () As Long
    Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function SetClassLong Lib "user32.dll" Alias "SetClassLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  
    Private hWnd                                    As Long
    Private WindowStyle                             As Long
#End If
 
    Private Const CS_DROPSHADOW                     As Long = &H20000
    Private Const GCL_STYLE                         As Long = (-26)
    Private Const GWL_STYLE                         As Long = (-16)
    Private Const GWL_EXSTYLE                       As Long = (-20)
    Private Const HTCAPTION                         As Long = 2
    Private Const WM_NCLBUTTONDOWN                  As Long = &HA1
    Private Const WS_CAPTION                        As Long = &HC00000
    Private Const WS_EX_DLGMODALFRAME               As Long = &H1
  
    Private WithEvents CancelBUtton                 As MSForms.CommandButton
    Private WithEvents cForm                        As MSForms.UserForm
    Private WithEvents NewTitleBar                  As MSForms.Label
    Private WithEvents NewTitleBarCaption           As MSForms.Label
    Private WithEvents NewCloseButton               As MSForms.Label
  
    Event CancelBUtton(ByRef Handled As Boolean)
  
    Private cDisplayCloseButton                     As Boolean
  
    Private cCaption                                As String
    Private cCaptionColor                           As Long
    Private cCaptionHoverColor                      As Long
    Private cDropShadow                             As Boolean
    Private cFocusOnForm                            As Boolean
    Private cFormSet                                As Boolean
    Private cHoverColor                             As Long
    Private cHoverColorSetByUser                    As Long
    Private cTitleBarColor                          As Long
    Private cTitleBarColorSetByUser                 As Long
  
    ' Class Events
      
    Private Sub Class_Initialize()
        cTitleBarColorSetByUser = -1
        cHoverColorSetByUser = -1
        cDisplayCloseButton = True
        cCaption = "Default"
    End Sub
  
    Private Sub Class_Terminate()
        Set cForm = Nothing
    End Sub
  
    ' Properties
  
    Public Property Get TitleBarColor() As Long
        TitleBarColor = cTitleBarColor
    End Property
  
    Public Property Let TitleBarColor(uColor As Long)
        cTitleBarColorSetByUser = uColor
        cCaptionColor = BlackOrWhite(cTitleBarColorSetByUser)
        If cFormSet = True Then Apply
    End Property
  
    Public Property Get HoverColor() As Long
        HoverColor = cHoverColor
    End Property
  
    Public Property Let HoverColor(uColor As Long)
        cHoverColorSetByUser = uColor
        cCaptionHoverColor = BlackOrWhite(cHoverColorSetByUser)
        If cFormSet = True Then Apply
    End Property
      
    Public Property Get DisplayCloseButton() As Boolean
        DisplayCloseButton = cDisplayCloseButton
    End Property
  
    Public Property Let DisplayCloseButton(uDisplayCloseButton As Boolean)
        cDisplayCloseButton = uDisplayCloseButton
        If cFormSet = True Then Apply
    End Property
  
    Public Property Set Form(uForm As Object)
        Set cForm = uForm
        cCaption = IIf(cCaption = "Default", uForm.Caption, cCaption)
        Call IUnknown_GetWindow(cForm, VarPtr(hWnd))
        Apply
      
        ' Applies dropshadow to userform to counter the removal of normal
        ' shadow resulting from style changes
        Call SetClassLong(hWnd, GCL_STYLE, GetClassLong(hWnd, GCL_STYLE) Or CS_DROPSHADOW)
        cFormSet = True
    End Property
          
    ' Prepares userform / applies colors to controls
          
    Public Sub Apply()
      
        HideTitleBorder
      
        Dim cFormBackColor                          As Long
      
        cFormBackColor = cForm.BackColor
      
        cTitleBarColor = IIf(cTitleBarColorSetByUser >= 0, cTitleBarColorSetByUser, cFormBackColor)
        cHoverColor = IIf(cHoverColorSetByUser >= 0, cHoverColorSetByUser, IIf(cTitleBarColorSetByUser >= 0, cTitleBarColorSetByUser, TintAndShade(cFormBackColor, -40)))
        cCaptionColor = BlackOrWhite(cTitleBarColor)
        cCaptionHoverColor = BlackOrWhite(cHoverColor)
      
        If NewTitleBar Is Nothing Then
            CreatePseudoTitleBar
        Else
            NewTitleBar.BackColor = cTitleBarColor
            NewTitleBarCaption.ForeColor = cCaptionColor
            NewCloseButton.BackColor = cTitleBarColor
        End If
    End Sub
 
    ' Creates the pseudo titlebar
 
    Private Sub CreatePseudoTitleBar()
        Set NewTitleBar = cForm.Controls.Add("Forms.Label.1", "lbTitleBar")
        With NewTitleBar
            .BackColor = cTitleBarColor
            .BackStyle = fmBackStyleOpaque
            .Left = 0
            .Top = 0
            .Height = 20
            .Width = cForm.InsideWidth
        End With
      
        Set NewTitleBarCaption = cForm.Controls.Add("Forms.Label.1", "lbTitleBarCaption")
        With NewTitleBarCaption
            .BackStyle = fmBackStyleTransparent
            .Caption = cCaption
            .Font.Name = "Segoe UI"
            .Font.Size = 9
            .ForeColor = cCaptionColor
            .Left = 6
            .Top = 4
            .Height = 20
            .Width = cForm.InsideWidth
            .AutoSize = True
        End With
      
        Set NewCloseButton = cForm.Controls.Add("Forms.Label.1", "lbCloseButton")
        With NewCloseButton
            .BackColor = cTitleBarColor
            .BackStyle = fmBackStyleOpaque
            .Height = 20
            .Width = 24
            .Left = cForm.InsideWidth - 24
            .Top = 0
            .PicturePosition = fmPicturePositionCenter
            .Picture = Application.CommandBars.GetImageMso("WindowClose", 16, 16)
        End With
      
        Set CancelBUtton = cForm.Controls.Add("Forms.CommandButton.1", "btnDefaultCancel")
        With CancelBUtton
            .TabStop = False
            .Cancel = True
            .Top = -40
        End With
        If cDisplayCloseButton = False Then NewCloseButton.Visible = False
   End Sub
 
   ' Events for dynamically created controls / pseudo titlebar
 
    Private Sub cForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        If cFocusOnForm = False Then
            NewCloseButton.BackColor = cTitleBarColor
            NewTitleBar.BackColor = cTitleBarColor
            NewTitleBarCaption.ForeColor = cCaptionColor
            cFocusOnForm = True
        End If
    End Sub
  
    ' Close routine for the pseudo closebutton
  
    Private Sub NewCloseButton_Click()
        Unload cForm
    End Sub
  
    Private Sub NewCloseButton_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        NewCloseButton.BackColor = vbRed
        cFocusOnCloseButton = True
    End Sub
  
    Private Sub NewTitleBarCaption_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        Debug.Print "Caption"
        If cFocusOnForm = True Then
            NewTitleBar.BackColor = cHoverColor
            NewCloseButton.BackColor = cHoverColor
            NewTitleBarCaption.ForeColor = cCaptionHoverColor
            cFocusOnForm = False
            cFocusOnCloseButton = False
        End If
        If Button Then
            MoveUserForm
        End If
          
    End Sub
  
    Private Sub NewTitleBar_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        Debug.Print "Titlebar"
        If cFocusOnForm = True Then
            NewTitleBar.BackColor = cHoverColor
            NewCloseButton.BackColor = cHoverColor
            NewTitleBarCaption.ForeColor = cCaptionHoverColor
            cFocusOnForm = False
            cFocusOnCloseButton = False
        End If
        If Button Then
            MoveUserForm
        End If
    End Sub
  
    ' Click event for the hidden command button that is dynamically-created
    ' with cancel property set to allow for easy use of escape key.
  
    Private Sub CancelButton_Click()
        Dim Handled As Boolean
        RaiseEvent CancelBUtton(Handled)
        If Handled = False Then
            Unload cForm
        End If
    End Sub
  
    ' Misc / Helper routines
  
    Private Sub HideTitleBorder()
        WindowStyle = GetWindowLong(hWnd, GWL_STYLE)
        WindowStyle = WindowStyle And (Not WS_CAPTION)
        SetWindowLong hWnd, GWL_STYLE, WindowStyle
        WindowStyle = GetWindowLong(hWnd, GWL_EXSTYLE)
        WindowStyle = WindowStyle And Not WS_EX_DLGMODALFRAME
        SetWindowLong hWnd, GWL_EXSTYLE, WindowStyle
        DrawMenuBar hWnd
    End Sub
  
    Private Sub MoveUserForm()
        ReleaseCapture
        SendMessage hWnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&
    End Sub

    Private Function TintAndShade(ByVal ColRef As Long, Optional ByVal Luminance As Long = 0) As Long
        ' Orignally sourced code written by Jaafar Tribak from https://www.mrexcel.com/board/threads/applying-tintandshade-to-a-userform-label.1189219/
        '(Luminance must be between -100 and +100)
        OleTranslateColor ColRef, 0, ColRef
        TintAndShade = ColorAdjustLuma(ColRef, Luminance * 10, True)
    End Function

    Private Function BlackOrWhite(Color As Long) As Long
        Dim cRed As Long, cGreen As Long, cBlue As Long
        cRed = Color And 255
        cGreen = (Color \ 256) And 255
        cBlue = (Color \ 65536) And 255
        If cRed * 0.3 + cGreen * 0.59 + cBlue * 0.11 < 128 Then BlackOrWhite = vbWhite
    End Function

 

[Dan_W]

From my personal experience, if Windows is themed, it is not easy to get the actual colors of the UI elements. I have had little success with GetSysColor, GetThemeColor, GetThemeSysColorBrush ...etc.

To be honest, I'm silently relieved it wasn't just me! I had read that the dark/light themes used in Windows 10 had rendered these APIs mostly unhelpful, though I wasn't aware of GetThemeColor and related APIs so thank you.

If all you want is to give the userfom the same color as its titlebar, you can cheat by reading the color of a pixel from the caption area. This is an inelegant hack but it is easy and it works regardless of the current applied themes if any.

I would need to check, but is this the approach you took in your 'Animated GIF in the titlebar' project (i.e., GetWindowRect / GetPixel)? I liked that approach, and the truth is that 'cheating' and 'inelegant hacks' are my favourite techniques! That said, if I always did that, I wouldn't have the opportunity to completely overengineer a solution like I have above!

 

[Jaafar Tribak]

Hi Dan_W

I like your solution in post#15. The code is nicely written and the final result is better than I had anticipated.

Application.CommandBars.GetImageMso("WindowClose", 16, 16)
I have had the need to draw the X close button many times before but never occured to me to use this GetImageMso handy Method. Thank you.

Some feedback:

1- Setting the CS_DROPSHADOW class style affects all userforms. The problem is removing the shadow (AND NOT CS_DROPSHADOW) upon closing the form doesn' seem to work. This will leave any subsequent userforms looking with a double frame (at least in win10) .

If I remember correctly,I worked around this issue before by drawing a frame around the userform instead of setting the GCL_STYLE but that involved more work.

2- When you hide the titlebar you will probably need to offset any pre-existing controls down by SM_CYCAPTION.

To be honest, I'm silently relieved it wasn't just me! I had read that the dark/light themes used in Windows 10 had rendered these APIs mostly unhelpful, though I wasn't aware of GetThemeColor and related APIs so thank you

Actually, after some search last night, I found this (credit goes to LeandroA) which I have slightly adapted for office (Unfortunately, all the functions are undocumeted in the uxtheme.dll and only accessible by ordinal # !!!)

In the UserForm Module

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function GetImmersiveUserColorSetPreference Lib "uxtheme.dll" Alias "#98" (ByVal bForceCheckRegistry As Long, ByVal bSkipCheckOnFail As Long) As Long
    Private Declare PtrSafe Function GetImmersiveColorTypeFromName Lib "uxtheme.dll" Alias "#96" (ByVal name As LongPtr) As Long
    Private Declare PtrSafe Function GetImmersiveColorFromColorSetEx Lib "uxtheme.dll" Alias "#95" (ByVal dwImmersiveColorSet As Long, ByVal dwImmersiveColorType As Long, ByVal bIgnoreHighContrast As Long, ByVal dwHighContrastCacheMode As Long) As Long
    Private Declare PtrSafe Function DwmSetWindowAttribute Lib "dwmapi.dll" (ByVal hwnd As LongPtr, ByVal dwAttribute As Long, ByRef pvAttribute As Long, ByVal cbAttribute As Long) As Long
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
#Else
    Private Declare Function GetImmersiveUserColorSetPreference Lib "uxtheme.dll" Alias "#98" (ByVal bForceCheckRegistry As Long, ByVal bSkipCheckOnFail As Long) As Long
    Private Declare Function GetImmersiveColorTypeFromName Lib "uxtheme.dll" Alias "#96" (ByVal name As Long) As Long
    Private Declare Function GetImmersiveColorFromColorSetEx Lib "uxtheme.dll" Alias "#95" (ByVal dwImmersiveColorSet As Long, ByVal dwImmersiveColorType As Long, ByVal bIgnoreHighContrast As Long, ByVal dwHighContrastCacheMode As Long) As Long
    Private Declare Function DwmSetWindowAttribute Lib "dwmapi.dll" (ByVal hwnd As Long, ByVal dwAttribute As Long, ByRef pvAttribute As Long, ByVal cbAttribute As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As Long) As Long
#End If


Private Function GetImmersiveColor(ByVal sName As String) As Long
    Dim lColorSet As Long, lColorType As Long, lRawColor As Long

    lColorSet = GetImmersiveUserColorSetPreference(0, 0)
    lColorType = GetImmersiveColorTypeFromName(StrPtr(sName))
    GetImmersiveColor = GetImmersiveColorFromColorSetEx(lColorSet, lColorType, 0, 0)
End Function


Private Sub UserForm_Initialize()
    Const DWMNCRP_ENABLED = 2
    Const DWMWA_NCRENDERING_POLICY = 2
 
    #If Win64 Then
        Dim hwnd As LongLong
    #Else
        Dim hwnd As Long
    #End If
    Call IUnknown_GetWindow(Me, VarPtr(hwnd))
    Call DwmSetWindowAttribute(hwnd, DWMWA_NCRENDERING_POLICY, DWMNCRP_ENABLED, 4)
    Me.BackColor = GetImmersiveColor("ImmersiveStartSelectionBackground") And &HFFFFFF
End Sub

Yet, there is a simpler method for themed windows10 by just reading the Accentcolor reg key:

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
#Else
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
#End If


Private Function GetTitleBarColor()
    Const COLOR_ACTIVECAPTION = 2
    On Error Resume Next
    GetTitleBarColor = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\DWM\Accentcolor") And &HFFFFFF
    If Err.Number Then
        GetTitleBarColor = GetSysColor(COLOR_ACTIVECAPTION)
    End If
End Function

Private Sub UserForm_Initialize()
   Me.BackColor = GetTitleBarColor
End Sub

 

[abdelfattah]

just question , the code in OP just work in win 32bit?

I downloaded your file . impressive and big work ! your file is very useful

I expect that there will possibly be some bugs in the code or adjustments that need to be made,

I hope to don't happen any error in the future . actually I don't test your codes in new file to see how works , just I tested your file .
if there is problem , I will inform you
thanks for this great work genuis

 

[Jaafar Tribak]

@Jaafar Tribak

I'm glad to share us your idea . actually your code works just in original color , if I select another color like red it will return to original color for the userform

any way thanks for your trying

Hi abdelfattah,

Do you mean if the user selects a different color theme from the Windows Settings while the userform is on display and if so, you want he form backcolor to change automatically to the new color chosen by the user ?

That is an unlikely request but I think it can be done by subclassing a top level window within the excel process and monitoring the broadcasted WM_SETTINGCHANGE window message .

 

[abdelfattah]

@Jaafar Tribak does the last code works like Dan's code?