How to change the UserForm Caption Font

[erik.van.geit]

Hi, guys and galls,

Please do the following.
Create a Userform
Change the FONT property: name or size or both

What do you expect? I thought that the caption font and size would change. But nothing happens.

Perhaps I am missing the obvious... What's the FONT property made for then?

If someone can help, that would be nice.

kind regards,
Erik

PS: some code I played with

Private Sub UserForm_Click()

Me.Font.Size = 10
Me.Font.Name = "Trebuchet MS"
MsgBox Me.Font.Name & vbNewLine & Me.Font.Size
 
Me.Font.Size = 40
Me.Font.Name = "Arial"
MsgBox Me.Font.Name & vbNewLine & Me.Font.Size

End Sub

 

[erik.van.geit]

Hi,

That's a great solution, Jaafar...
And it didn't crash Excel on my machine

kind regards,
Erik

 

[hymced]

Hi all,

Old thread but found this challenging as nowhere on the internet could I find a solution apart from the little hack of removing the whole title bar of the userform and faking one with a label.

As a result of some stubborn trying and some nasty application crashing , I seem to have achieved a rather nice looking/functionning userform with a formatted title bar and a formatted caption text.

here is a WORKBOOK DEMO.

Here is the main code in a standard module :

Option Explicit
 
Private Type POINTAPI
    x As Long
    y As Long
End Type
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type
 
Private Type PAINTSTRUCT
    hdc As Long
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(32) As Byte
End Type
 
 
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As String * 1
    lfUnderline As String * 1
    lfStrikeOut As String * 1
    lfCharSet As String * 1
    lfOutPrecision As String * 1
    lfClipPrecision As String * 1
    lfQuality As String * 1
    lfPitchAndFamily As String * 1
    lfFaceName As String * 32
End Type
 
Private Declare Function CreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" _
(lpLogFont As LOGFONT) As Long
 
Private Declare Function GetWindowDC Lib "user32" _
 (ByVal hwnd As Long) As Long
 
Private Declare Function SendMessage Lib "user32.dll" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any) As Long
 
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, _
ByVal hdc As Long) As Long
 
Private Declare Function TextOut Lib "gdi32" _
Alias "TextOutA" _
(ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal lpString As String, _
ByVal nCount As Long) As Long
 
Private Declare Function SetBkMode Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nBkMode As Long) As Long
 
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
 
Private Declare Function SetWindowsHookEx Lib _
"user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
 
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
 
Private Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, _
ByVal ncode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
 
Private Declare Function GetCurrentThreadId Lib "kernel32" _
() As Long
 
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 CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
 
Private Declare Function GetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
 
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
 
Private Declare Function SetTextColor Lib "gdi32" _
(ByVal hdc As Long, _
ByVal crColor As Long) As Long
 
Private Declare Function CreateBrushIndirect Lib "gdi32" _
(lpLogBrush As LOGBRUSH) As Long
 
Private Declare Function FillRect Lib "user32.dll" _
(ByVal hdc As Long, _
ByRef lpRect As RECT, _
ByVal hBrush As Long) As Long
 
Private Declare Function SetRect Lib "user32" _
(lpRect As RECT, _
ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
 
Private Declare Function GetWindowRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpRect As RECT) As Long
 
Private Declare Function BeginPaint Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpPaint As PAINTSTRUCT) As Long
 
Private Declare Function EndPaint Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpPaint As PAINTSTRUCT) As Long
 
Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long
 
Private Declare Function RedrawWindow Lib "user32" _
(ByVal hwnd As Long, _
lprcUpdate As Any, _
ByVal hrgnUpdate As Long, _
ByVal fuRedraw As Long) As Long
 
Private Declare Function InvalidateRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal lpRect As Long, _
ByVal bErase As Long) As Long
 
Private Declare Function SetCursorPos Lib "user32.dll" _
(ByVal x As Long, _
ByVal y As Long) As Long
 
Private Declare Function GetCursorPos Lib "user32.dll" _
(ByRef lpPoint As POINTAPI) As Long
 
Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long

Private Const WH_CBT As Long = 5
Private Const HCBT_ACTIVATE As Long = 5
Private Const GWL_WNDPROC As Long = -4
 
Private Const WM_ACTIVATE As Long = &H6
Private Const WM_PAINT As Long = &HF&
Private Const WM_SHOWWINDOW As Long = &H18
Private Const WM_EXITSIZEMOVE As Long = &H232
Private Const WM_DESTROY As Long = &H2
 
Private Const RDW_INTERNALPAINT As Long = &H2
 
Private Const SM_CXSCREEN As Long = 0
Private Const SM_CYSCREEN As Long = 1
Private Const SM_CYCAPTION As Long = 4
 
Private tPoint As POINTAPI
Private tRect As RECT
Private lPrevWnd As Long
Private lhHook As Long
Private bHookEnabled As Boolean
Private oForm As Object
Private sCaptionText As String
Private lCaptionColour As Long
Private lFontSize As Long
Private lFontColour As Long
Private bBold As Boolean

Sub HookUserForm _
 (ByVal Form, ByVal CaptionColour, _
 ByVal FontColour, ByVal FontSize, ByVal Bold)
 
    'install a cbt hook to monitor for
    'the activation of a window.
    If Not bHookEnabled Then
        'store parms in mod level vars.
        Set oForm = Form
        sCaptionText = Form.Caption
        lCaptionColour = CaptionColour
        lFontColour = FontColour
        lFontSize = FontSize
        bBold = Bold
        lhHook = SetWindowsHookEx _
        (WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId)
        bHookEnabled = True
        'show userform.
        Form.Show
    Else
        MsgBox "The hook is already set.", vbInformation
    End If
 
End Sub
 
Private Sub TerminateHook()
 
   'important to unhook when done!
    UnhookWindowsHookEx lhHook
    bHookEnabled = False
 
End Sub
 
Private Function HookProc _
(ByVal idHook As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
 
    Dim sBuffer As String
    Dim lRetVal As Long
    
    'check if a window has been activated.
    If idHook = HCBT_ACTIVATE Then
    
    'if so,get it's class name.
    sBuffer = Space(256)
    lRetVal = GetClassName(wParam, sBuffer, 256)
    
    'check if it is an xl userform window
    'that is being activated.
    
    If Left(sBuffer, lRetVal) = "ThunderDFrame" Or _
    Left(sBuffer, lRetVal) = "ThunderXFrame" Then
    
    'if so,subclass it .
    lPrevWnd = SetWindowLong _
    (wParam, GWL_WNDPROC, AddressOf CallBackProc)
    
    'done. so remove CBT hook.
    Call TerminateHook
    End If
    
    End If
    
    'Call next hook.
    HookProc = CallNextHookEx _
    (lhHook, idHook, ByVal wParam, ByVal lParam)
 
End Function
 
Private Function CallBackProc _
(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
 
    Dim lDc As Long
    
    On Error Resume Next
    'get current userform position.
    GetWindowRect hwnd, tRect
    Select Case Msg
        Case WM_PAINT, WM_ACTIVATE
            If Msg = WM_ACTIVATE Then
                Call MoveCursor
            End If
            lDc = GetWindowDC(hwnd)
            Call DrawTitleBar(hwnd, lCaptionColour)
            SetBkMode lDc, 1
            SetTextColor lDc, lFontColour
            CreateFont lDc, Bold:=bBold
            TextOut lDc, 6, GetSystemMetrics(SM_CYCAPTION) / 3, _
            sCaptionText, Len(sCaptionText)
            ReleaseDC hwnd, lDc
            InvalidateRect hwnd, 0, 0
        Case WM_EXITSIZEMOVE, WM_SHOWWINDOW
            If Msg = WM_SHOWWINDOW Then
                SetCursorPos tPoint.x, tPoint.y
            End If
            SendMessage hwnd, WM_PAINT, 0, 0
            Call MoveCursor
        Case WM_DESTROY
            SetWindowLong hwnd, GWL_WNDPROC, lPrevWnd
    End Select
    
    'process other msgs.
    CallBackProc = CallWindowProc _
    (lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
 
End Function
 
Private Sub CreateFont(DC As Long, Optional Bold As Boolean)
 
    Dim uFont As LOGFONT
    Dim lNewFont As Long
    
    With uFont
        .lfFaceName = "Tahoma" & Chr$(0)
        .lfHeight = lFontSize
        .lfWidth = 8
        .lfWeight = IIf(Bold, 900, 100)
    End With
    
    lNewFont = CreateFontIndirect(uFont)
    DeleteObject (SelectObject(DC, lNewFont))
 
End Sub
 
Private Sub DrawTitleBar _
(lhwnd As Long, Color)
 
    Dim tPS As PAINTSTRUCT
    Dim tLB As LOGBRUSH
    Dim tR As RECT
    Dim lDc As Long
    Dim l As Long
    Dim hBrush As Long
 
    BeginPaint lhwnd, tPS
    lDc = GetWindowDC(lhwnd)
    tLB.lbColor = Color
    'Create a new brush
    hBrush = CreateBrushIndirect(tLB)
    
    With oForm
        SetRect tR, 0, 0, GetSystemMetrics _
        (SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN)
    End With
    'Fill the form with our brush
'    FillRect lDc, tR, hBrush
      FillRect lDc, tR, hBrush
    
    Call DeleteObject(hBrush)
    RedrawWindow lhwnd, ByVal 0&, ByVal 0&, RDW_INTERNALPAINT
    DeleteDC lDc
    Call EndPaint(lhwnd, tPS)
 
End Sub

Private Sub DrawCloseButton()
 
    DoEvents
    SetCursorPos tPoint.x, tPoint.y
    
End Sub
 
Private Sub MoveCursor()
 
    GetCursorPos tPoint
    SetCursorPos tRect.Right - 15, tRect.Top + 15
    Application.OnTime Now + TimeSerial(0, 0, 0.1), _
    "DrawCloseButton"
 
End Sub
 
'=========Wrapper function===============.
Sub ShowFormatedUserForm( _
 _
    ByVal Form As Object, _
    ByVal CaptionColor As Long, _
    Optional ByVal FontColour As Long = vbWhite, _
    Optional ByVal FontSize As Long = 12, _
    Optional ByVal Bold As Boolean = False)
        Call HookUserForm _
 _
            (ByVal Form, _
            ByVal CaptionColor, _
            ByVal FontColour, _
            ByVal FontSize, _
            ByVal Bold)
End Sub

And below is an example of how to format a userform via the above wrapper function :

Sub Test()
 
Call ShowFormatedUserForm( _
 _
    Form:=UserForm1, _
    CaptionColor:=vbMagenta, _
    FontColour:=vbYellow, _
    FontSize:=14, _
    Bold:=True)

End Sub

Tested on Win XP sp2 excel 2003 only.

Regards.

Hello Jaafar,

I've just dug up this awesome code of yours to test it with Win 10 + Excel 2016.
Here is what it gives:

I had to make some adjustments to your initial code :

The main one was to comment out the line InvalidateRect since it was invalidating the region, which makes the system send another WC_PAINT message to the window, and you have a beautiful infinite loop here
Before removing this, the caption text was flickering for 2 sec then it eventually led to an unexpected behavior: the scrollbars and some controls of my IDE was painted with "UserForm8", VBE very little responsive, very much buggy, and finally crashed.

I also modified the rectangle for the FillRect method to paint only the required area

Find the code below.

BUT NOW: I'd like the UserForm window to keep its shadow so it resembles more to normal window. I made an attempt to proceed with the painting of the shadow by forwarding the message to the previous window proc but with an altered region containing only the shadow, so it does not repaint my new border. Obviously, you can see it does not work...

Do you have any idea on how to do it?

PS: why the 'GetSystemMetrics(SM_CYCAPTION) / 3' ? or rather: why the '/ 3' ? I can't find anywhere to what the SM_CYCAPTION metric corresponds to exactly, so I am a bit surprised that the returned value / 3 actual places the text perfectly centered vertically in the bar...

Private Type POINTAPI
    x As Long
    y As Long
End Type


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


Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type


Private Type PAINTSTRUCT
    hdc As Long
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(32) As Byte
End Type


Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As String * 1
    lfUnderline As String * 1
    lfStrikeOut As String * 1
    lfCharSet As String * 1
    lfOutPrecision As String * 1
    lfClipPrecision As String * 1
    lfQuality As String * 1
    lfPitchAndFamily As String * 1
    lfFaceName As String * 32
End Type


Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
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 CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function BeginPaint Lib "user32.dll" (ByVal hwnd As Long, ByRef lpPaint As PAINTSTRUCT) As Long
Private Declare Function EndPaint Lib "user32.dll" (ByVal hwnd As Long, ByRef lpPaint As PAINTSTRUCT) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Declare Function InvalidateRect Lib "user32.dll" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
Private Declare Function SetCursorPos Lib "user32.dll" (ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long


Private Const WH_CBT As Long = 5
Private Const HCBT_ACTIVATE As Long = 5
Private Const GWL_WNDPROC As Long = -4


Private Const WM_ACTIVATE As Long = &H6
Private Const WM_PAINT As Long = &HF&
Private Const WM_SHOWWINDOW As Long = &H18&
Private Const WM_EXITSIZEMOVE As Long = &H232&
Private Const WM_DESTROY As Long = &H2&


Private Const RDW_INTERNALPAINT As Long = &H2


Private Const SM_CXSCREEN As Long = 0
Private Const SM_CYSCREEN As Long = 1
Private Const SM_CYCAPTION As Long = 4


Private tPoint As POINTAPI
Private tRect As RECT
Private lPrevWnd As Long
Private lhHook As Long
Private bHookEnabled As Boolean
Private oForm As Object
Private sCaptionText As String
Private lCaptionColor As Long
Private lFontSize As Long
Private lFontColor As Long
Private bBold As Boolean


Private Declare Function GetDCEx Lib "user32" (ByVal hwnd As Long, ByVal hrgnClip As Long, ByVal flags As Long) As Long
Private Declare Function OffsetClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal nXOffset As Long, ByVal nYOffset As Long) As Long
Private Const WM_NCPAINT As Long = &H85&
Private Const WM_ERASEBKGND As Long = &H14&
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal nLeftRect As Long, ByVal nTopRect As Long, ByVal nRightRect As Long, ByVal nBottomRect As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hdestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Const RGN_AND = 1
Private Const RGN_OR = 2
Private Const RGN_XOR = 3
Private Const RGN_DIFF = 4
Private Const RGN_COPY = 5
Private Const NULLREGION = 1    'The region is empty.
Private Const SIMPLEREGION = 2  'The region is a single rectangle.
Private Const COMPLEXREGION = 3 'The region is more than a single rectangle.
Private Const ERROR = 0         'No region is created.


'GetDCEx Flags
Public Const DCX_WINDOW As Long = &H1&
Public Const DCX_CACHE As Long = &H2&
Public Const DCX_PARENTCLIP As Long = &H20&
Public Const DCX_CLIPSIBLINGS As Long = &H10&
Public Const DCX_CLIPCHILDREN As Long = &H8&
Public Const DCX_NORESETATTRS As Long = &H4&
Public Const DCX_LOCKWINDOWUPDATE As Long = &H400&
Public Const DCX_EXCLUDERGN As Long = &H40&
Public Const DCX_INTERSECTRGN As Long = &H80&
Public Const DCX_INTERSECTUPDATE As Long = &H200&
Public Const DCX_VALIDATE As Long = &H200000


Sub HookUserForm(ByVal Form, ByVal CaptionColor, ByVal FontColor, ByVal FontSize, ByVal Bold)
    'install a cbt hook to detect the activation of a window
    If Not bHookEnabled Then
        'store params in mod level vars
        Set oForm = Form
        sCaptionText = Form.Caption
        lCaptionColor = CaptionColor
        lFontColor = FontColor
        lFontSize = FontSize
        bBold = Bold
        lhHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId)
        bHookEnabled = True
        'show userform
        Form.Show
    Else
        MsgBox "The hook is already set", vbInformation
    End If
End Sub


Private Sub TerminateHook()
   'important to unhook when done!
    UnhookWindowsHookEx lhHook
    bHookEnabled = False
End Sub


Private Function HookProc(ByVal idHook As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim sBuffer As String
    Dim lRetVal As Long
    
    'check if a window has been activated
    If idHook = HCBT_ACTIVATE Then
        'if so, get its class name
        sBuffer = Space(256)
        lRetVal = GetClassName(wParam, sBuffer, 256)
        'check if it is an xl userform window that is being activated
        If Left(sBuffer, lRetVal) = "ThunderDFrame" Or _
            Left(sBuffer, lRetVal) = "ThunderXFrame" Then
            'if so, subclass it
            lPrevWnd = SetWindowLong(wParam, GWL_WNDPROC, AddressOf CallBackProc)
            'done, so remove CBT hook
            Call TerminateHook
        End If
    End If
    'call next hook
    HookProc = CallNextHookEx _
    (lhHook, idHook, ByVal wParam, ByVal lParam)
End Function
 
Private Function CallBackProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim lDc As Long
    
    On Error Resume Next
    'get current userform position
    GetWindowRect hwnd, tRect
    Select Case Msg
        Case WM_PAINT, WM_ACTIVATE, WM_NCPAINT
            If Msg = WM_ACTIVATE Then
                Call MoveCursor
            End If
            
            'attempt to paint only the window's shadow
            If Msg = WM_NCPAINT Then 'wParam = A handle to the update region of the window. The update region is clipped to the window frame.
                
                Dim hRgnOriginalWnd
                Dim hRgnWindowWithoutShadow
                Dim hRgnNewWnd
            
                Dim rcWnd As RECT
                ret& = GetWindowRect(hwnd, rcWnd)
                
                hRgnOriginalWnd = CreateRectRgn(0, 0, rcWnd.Right - rcWnd.Left, rcWnd.Bottom - rcWnd.Top)
                hRgnWindowWithoutShadow = CreateRectRgn(11, 0, rcWnd.Right - rcWnd.Left - 2 * 11, rcWnd.Bottom - rcWnd.Top - 1 * 11)
                hRgnNewWnd = CreateRectRgn(0, 0, 0, 0)
                
                ret = CombineRgn(hRgnNewWnd, hRgnOriginalWnd, hRgnWindowWithoutShadow, RGN_XOR)
                
                CallBackProc = CallWindowProc(lPrevWnd, hwnd, Msg, hRgnNewWnd, 0)
    
            End If
            
            lDc = GetWindowDC(hwnd)
            Call DrawTitleBar(hwnd, lCaptionColor)
            SetBkMode lDc, 1
            SetTextColor lDc, lFontColor
            CreateFont lDc, Bold:=bBold
            TextOut lDc, 28, GetSystemMetrics(SM_CYCAPTION) / 3, sCaptionText, Len(sCaptionText)  'also 14 pixels aways from client
            ReleaseDC hwnd, lDc
            'InvalidateRect hwnd, 0, 0
            
        Case WM_EXITSIZEMOVE, WM_SHOWWINDOW
            If Msg = WM_SHOWWINDOW Then
                SetCursorPos tPoint.x, tPoint.y
            End If
            'SendMessage hwnd, WM_PAINT, 0, 0
            Call MoveCursor
        Case WM_DESTROY
            SetWindowLong hwnd, GWL_WNDPROC, lPrevWnd
        Case Else
            'fallback to process other messages
            CallBackProc = CallWindowProc(lPrevWnd, hwnd, Msg, wParam, lParam)
    End Select
    
End Function
 
Private Sub CreateFont(DC As Long, Optional Bold As Boolean)
    Dim uFont As LOGFONT
    Dim lNewFont As Long
    
    With uFont
        .lfFaceName = "Tahoma" & Chr$(0)
        .lfHeight = 28
        '.lfWidth = 10 'commented out to use default
        .lfWeight = IIf(Bold, 900, 100)
    End With
    lNewFont = CreateFontIndirect(uFont)
    DeleteObject (SelectObject(DC, lNewFont))
End Sub
 
Private Sub DrawTitleBar(lhwnd As Long, Color)
    Dim tPS As PAINTSTRUCT
    Dim tLB As LOGBRUSH
    Dim tR As RECT
    Dim lDc As Long
    Dim l As Long
    Dim hBrush As Long
    
    BeginPaint lhwnd, tPS
    lDc = GetWindowDC(lhwnd)
    tLB.lbColor = Color
    'create a new brush
    hBrush = CreateBrushIndirect(tLB)
    
    'only the window's frame (as a Windows 10 styled window)
    Dim usfRECT As RECT
    GetWindowRect lhwnd, usfRECT
    SetRect tR, 11, 0, usfRECT.Right - usfRECT.Left - 1 * 11, usfRECT.Bottom - usfRECT.Top - 1 * 11 'shadow is 11 pixels wide
    FillRect lDc, tR, hBrush
    
    'clean up
    Call DeleteObject(hBrush)
    RedrawWindow lhwnd, ByVal 0&, ByVal 0&, RDW_INTERNALPAINT
    DeleteDC lDc
    Call EndPaint(lhwnd, tPS)
    
End Sub


Private Sub DrawCloseButton()
    DoEvents
    SetCursorPos tPoint.x, tPoint.y
End Sub


Private Sub MoveCursor()
    GetCursorPos tPoint
    SetCursorPos tRect.Right - 15, tRect.Top + 15
    Application.OnTime Now + TimeSerial(0, 0, 0.1), "DrawCloseButton"
End Sub
 
'Wrapper function
Sub ShowFormatedUserForm(ByVal Form As Object, ByVal CaptionColor As Long, _
    Optional ByVal FontColor As Long = vbBlack, _
    Optional ByVal FontSize As Long = 27, _
    Optional ByVal Bold As Boolean = False)


    Call HookUserForm(ByVal Form, ByVal CaptionColor, ByVal FontColor, ByVal FontSize, ByVal Bold)
End Sub

 

[Jaafar Tribak]

Hello Jaafar,

I've just dug up this awesome code of yours to test it with Win 10 + Excel 2016.
Here is what it gives:

I had to make some adjustments to your initial code :

The main one was to comment out the line InvalidateRect since it was invalidating the region, which makes the system send another WC_PAINT message to the window, and you have a beautiful infinite loop here
Before removing this, the caption text was flickering for 2 sec then it eventually led to an unexpected behavior: the scrollbars and some controls of my IDE was painted with "UserForm8", VBE very little responsive, very much buggy, and finally crashed.

I also modified the rectangle for the FillRect method to paint only the required area

Find the code below.

BUT NOW: I'd like the UserForm window to keep its shadow so it resembles more to normal window. I made an attempt to proceed with the painting of the shadow by forwarding the message to the previous window proc but with an altered region containing only the shadow, so it does not repaint my new border. Obviously, you can see it does not work...

Do you have any idea on how to do it?

PS: why the 'GetSystemMetrics(SM_CYCAPTION) / 3' ? or rather: why the '/ 3' ? I can't find anywhere to what the SM_CYCAPTION metric corresponds to exactly, so I am a bit surprised that the returned value / 3 actual places the text perfectly centered vertically in the bar...

Private Type POINTAPI
    x As Long
    y As Long
End Type


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


Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type


Private Type PAINTSTRUCT
    hdc As Long
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(32) As Byte
End Type


Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As String * 1
    lfUnderline As String * 1
    lfStrikeOut As String * 1
    lfCharSet As String * 1
    lfOutPrecision As String * 1
    lfClipPrecision As String * 1
    lfQuality As String * 1
    lfPitchAndFamily As String * 1
    lfFaceName As String * 32
End Type


Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
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 CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function BeginPaint Lib "user32.dll" (ByVal hwnd As Long, ByRef lpPaint As PAINTSTRUCT) As Long
Private Declare Function EndPaint Lib "user32.dll" (ByVal hwnd As Long, ByRef lpPaint As PAINTSTRUCT) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Declare Function InvalidateRect Lib "user32.dll" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
Private Declare Function SetCursorPos Lib "user32.dll" (ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long


Private Const WH_CBT As Long = 5
Private Const HCBT_ACTIVATE As Long = 5
Private Const GWL_WNDPROC As Long = -4


Private Const WM_ACTIVATE As Long = &H6
Private Const WM_PAINT As Long = &HF&
Private Const WM_SHOWWINDOW As Long = &H18&
Private Const WM_EXITSIZEMOVE As Long = &H232&
Private Const WM_DESTROY As Long = &H2&


Private Const RDW_INTERNALPAINT As Long = &H2


Private Const SM_CXSCREEN As Long = 0
Private Const SM_CYSCREEN As Long = 1
Private Const SM_CYCAPTION As Long = 4


Private tPoint As POINTAPI
Private tRect As RECT
Private lPrevWnd As Long
Private lhHook As Long
Private bHookEnabled As Boolean
Private oForm As Object
Private sCaptionText As String
Private lCaptionColor As Long
Private lFontSize As Long
Private lFontColor As Long
Private bBold As Boolean


Private Declare Function GetDCEx Lib "user32" (ByVal hwnd As Long, ByVal hrgnClip As Long, ByVal flags As Long) As Long
Private Declare Function OffsetClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal nXOffset As Long, ByVal nYOffset As Long) As Long
Private Const WM_NCPAINT As Long = &H85&
Private Const WM_ERASEBKGND As Long = &H14&
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal nLeftRect As Long, ByVal nTopRect As Long, ByVal nRightRect As Long, ByVal nBottomRect As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hdestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Const RGN_AND = 1
Private Const RGN_OR = 2
Private Const RGN_XOR = 3
Private Const RGN_DIFF = 4
Private Const RGN_COPY = 5
Private Const NULLREGION = 1    'The region is empty.
Private Const SIMPLEREGION = 2  'The region is a single rectangle.
Private Const COMPLEXREGION = 3 'The region is more than a single rectangle.
Private Const ERROR = 0         'No region is created.


'GetDCEx Flags
Public Const DCX_WINDOW As Long = &H1&
Public Const DCX_CACHE As Long = &H2&
Public Const DCX_PARENTCLIP As Long = &H20&
Public Const DCX_CLIPSIBLINGS As Long = &H10&
Public Const DCX_CLIPCHILDREN As Long = &H8&
Public Const DCX_NORESETATTRS As Long = &H4&
Public Const DCX_LOCKWINDOWUPDATE As Long = &H400&
Public Const DCX_EXCLUDERGN As Long = &H40&
Public Const DCX_INTERSECTRGN As Long = &H80&
Public Const DCX_INTERSECTUPDATE As Long = &H200&
Public Const DCX_VALIDATE As Long = &H200000


Sub HookUserForm(ByVal Form, ByVal CaptionColor, ByVal FontColor, ByVal FontSize, ByVal Bold)
    'install a cbt hook to detect the activation of a window
    If Not bHookEnabled Then
        'store params in mod level vars
        Set oForm = Form
        sCaptionText = Form.Caption
        lCaptionColor = CaptionColor
        lFontColor = FontColor
        lFontSize = FontSize
        bBold = Bold
        lhHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId)
        bHookEnabled = True
        'show userform
        Form.Show
    Else
        MsgBox "The hook is already set", vbInformation
    End If
End Sub


Private Sub TerminateHook()
   'important to unhook when done!
    UnhookWindowsHookEx lhHook
    bHookEnabled = False
End Sub


Private Function HookProc(ByVal idHook As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim sBuffer As String
    Dim lRetVal As Long
    
    'check if a window has been activated
    If idHook = HCBT_ACTIVATE Then
        'if so, get its class name
        sBuffer = Space(256)
        lRetVal = GetClassName(wParam, sBuffer, 256)
        'check if it is an xl userform window that is being activated
        If Left(sBuffer, lRetVal) = "ThunderDFrame" Or _
            Left(sBuffer, lRetVal) = "ThunderXFrame" Then
            'if so, subclass it
            lPrevWnd = SetWindowLong(wParam, GWL_WNDPROC, AddressOf CallBackProc)
            'done, so remove CBT hook
            Call TerminateHook
        End If
    End If
    'call next hook
    HookProc = CallNextHookEx _
    (lhHook, idHook, ByVal wParam, ByVal lParam)
End Function
 
Private Function CallBackProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim lDc As Long
    
    On Error Resume Next
    'get current userform position
    GetWindowRect hwnd, tRect
    Select Case Msg
        Case WM_PAINT, WM_ACTIVATE, WM_NCPAINT
            If Msg = WM_ACTIVATE Then
                Call MoveCursor
            End If
            
            'attempt to paint only the window's shadow
            If Msg = WM_NCPAINT Then 'wParam = A handle to the update region of the window. The update region is clipped to the window frame.
                
                Dim hRgnOriginalWnd
                Dim hRgnWindowWithoutShadow
                Dim hRgnNewWnd
            
                Dim rcWnd As RECT
                ret& = GetWindowRect(hwnd, rcWnd)
                
                hRgnOriginalWnd = CreateRectRgn(0, 0, rcWnd.Right - rcWnd.Left, rcWnd.Bottom - rcWnd.Top)
                hRgnWindowWithoutShadow = CreateRectRgn(11, 0, rcWnd.Right - rcWnd.Left - 2 * 11, rcWnd.Bottom - rcWnd.Top - 1 * 11)
                hRgnNewWnd = CreateRectRgn(0, 0, 0, 0)
                
                ret = CombineRgn(hRgnNewWnd, hRgnOriginalWnd, hRgnWindowWithoutShadow, RGN_XOR)
                
                CallBackProc = CallWindowProc(lPrevWnd, hwnd, Msg, hRgnNewWnd, 0)
    
            End If
            
            lDc = GetWindowDC(hwnd)
            Call DrawTitleBar(hwnd, lCaptionColor)
            SetBkMode lDc, 1
            SetTextColor lDc, lFontColor
            CreateFont lDc, Bold:=bBold
            TextOut lDc, 28, GetSystemMetrics(SM_CYCAPTION) / 3, sCaptionText, Len(sCaptionText)  'also 14 pixels aways from client
            ReleaseDC hwnd, lDc
            'InvalidateRect hwnd, 0, 0
            
        Case WM_EXITSIZEMOVE, WM_SHOWWINDOW
            If Msg = WM_SHOWWINDOW Then
                SetCursorPos tPoint.x, tPoint.y
            End If
            'SendMessage hwnd, WM_PAINT, 0, 0
            Call MoveCursor
        Case WM_DESTROY
            SetWindowLong hwnd, GWL_WNDPROC, lPrevWnd
        Case Else
            'fallback to process other messages
            CallBackProc = CallWindowProc(lPrevWnd, hwnd, Msg, wParam, lParam)
    End Select
    
End Function
 
Private Sub CreateFont(DC As Long, Optional Bold As Boolean)
    Dim uFont As LOGFONT
    Dim lNewFont As Long
    
    With uFont
        .lfFaceName = "Tahoma" & Chr$(0)
        .lfHeight = 28
        '.lfWidth = 10 'commented out to use default
        .lfWeight = IIf(Bold, 900, 100)
    End With
    lNewFont = CreateFontIndirect(uFont)
    DeleteObject (SelectObject(DC, lNewFont))
End Sub
 
Private Sub DrawTitleBar(lhwnd As Long, Color)
    Dim tPS As PAINTSTRUCT
    Dim tLB As LOGBRUSH
    Dim tR As RECT
    Dim lDc As Long
    Dim l As Long
    Dim hBrush As Long
    
    BeginPaint lhwnd, tPS
    lDc = GetWindowDC(lhwnd)
    tLB.lbColor = Color
    'create a new brush
    hBrush = CreateBrushIndirect(tLB)
    
    'only the window's frame (as a Windows 10 styled window)
    Dim usfRECT As RECT
    GetWindowRect lhwnd, usfRECT
    SetRect tR, 11, 0, usfRECT.Right - usfRECT.Left - 1 * 11, usfRECT.Bottom - usfRECT.Top - 1 * 11 'shadow is 11 pixels wide
    FillRect lDc, tR, hBrush
    
    'clean up
    Call DeleteObject(hBrush)
    RedrawWindow lhwnd, ByVal 0&, ByVal 0&, RDW_INTERNALPAINT
    DeleteDC lDc
    Call EndPaint(lhwnd, tPS)
    
End Sub


Private Sub DrawCloseButton()
    DoEvents
    SetCursorPos tPoint.x, tPoint.y
End Sub


Private Sub MoveCursor()
    GetCursorPos tPoint
    SetCursorPos tRect.Right - 15, tRect.Top + 15
    Application.OnTime Now + TimeSerial(0, 0, 0.1), "DrawCloseButton"
End Sub
 
'Wrapper function
Sub ShowFormatedUserForm(ByVal Form As Object, ByVal CaptionColor As Long, _
    Optional ByVal FontColor As Long = vbBlack, _
    Optional ByVal FontSize As Long = 27, _
    Optional ByVal Bold As Boolean = False)


    Call HookUserForm(ByVal Form, ByVal CaptionColor, ByVal FontColor, ByVal FontSize, ByVal Bold)
End Sub

Hi hymced,

Thanks for your interest in this.

It is now difficult for me to revise the code for two reasons : one because it is a rather complicated and seond because I currently work on 64 bit excel which means I have to re-write the whole code from scratch.

My first quick attempt to make this work for 64bit turned out unsuccessful but I'll try again and hope something good comes up.

BTW, have you seen this project in this thread (Post#10) ?... It is much better as it enables changing the font for each individual caracter in the userform caption as well as the color of the Non-Client area of the userform + a gradient fill making it look more like a "normal" window.

 

[Jaafar Tribak]

Hello Jaafar,

I've just dug up this awesome code of yours to test it with Win 10 + Excel 2016...
BUT NOW: I'd like the UserForm window to keep its shadow so it resembles more to normal window.

Demo Workbook

Hi hymced,

It is not easy to format the Non Client area of a userform and keep its shadow effect at the same time specially with different visual themes on different windows platforms.

However, I managed to come as close to the shadow you require (Not perfect) by adding the CS_DROPSHADOW class style.

Adding a decent interactive X close button to the userform titlebar after painting the NClient area turned out more difficult than I expected.

I tested the code on Excel 2007, Excel 2010, Win XP, Win7 and Win10 64bit and didn't notice any issues.

Note that this only works with Modal userforms

Here is the signature of the routine that does the job :

Public Sub FormatFormCaption( _
ByVal Form As Object, _
Optional ByVal TitleBarColor As Variant, _
Optional ByVal GradientFill As Boolean, _
Optional ByVal DropShadow As Boolean, _
Optional ByVal FontName As String, _
Optional ByVal FontColor As Long, _
Optional ByVal FontSize As Long, _
Optional ByVal FontBold As Boolean, _
Optional ByVal FontItalic As Boolean, _
Optional ByVal FontUnderline As Boolean _
)

As you can see, the above SUB should enable the user to flexibly set many optional attributes in just one call.. Attributes such as the TitleBar backColor, Gradient fill, Frame shadow and all text Font attributes you wish.

1- Code in a Standard Module:

'API-based code to enable the following formatting functionalities to the Non-Client area of a vba userform.'- NClient Color ,GradientFill, DropShadow, Caption Font and close button.
'Note: This code works only with MODAL userforms.
'Written by Jaafar Tribak @ MrExcel.com on 22/06/2018.

Option Explicit
 
'API Structures.
Private Type POINTAPI
    x As Long
    y As Long
End Type
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
     [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        lbHatch As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        lbHatch As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
End Type

Private Type PAINTSTRUCT
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        hdc As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        hdc As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(0 To 31) As Byte
End Type

Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName As String * 32
End Type

Private Type TRIVERTEX
    x As Long
    y As Long
    Red As Integer
    Green As Integer
    Blue As Integer
    Alpha As Integer
End Type

Private Type GRADIENT_RECT
    UpperLeft As Long
    LowerRight As Long
End Type

'API Function Declarations.
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) As Long
        Private Declare PtrSafe Function GetClassLong Lib "user32" Alias "GetClassLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetClassLong Lib "user32" Alias "SetClassLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
        Private Declare PtrSafe Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
    Private Declare PtrSafe Function GetWindowDC 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 TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
    Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hdc As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As LongPtr
    Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function BeginPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As LongPtr
    Private Declare PtrSafe Function EndPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function SetMapMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nMapMode As Long) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GradientFillRect Lib "msimg32" Alias "GradientFill" (ByVal hdc As LongPtr, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long
    Private Declare PtrSafe Function DrawFrameControl Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal un1 As Long, ByVal un2 As Long) As Long
    Private Declare PtrSafe Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
    Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function IsWindowEnabled Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT, ByVal bErase As Long) As Long
    
    Private lPrevWinProc As LongPtr, lHook As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    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 PtInRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
    Private Declare Function GetWindowDC 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 TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As Long) As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
    Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
    Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
    Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
    Private Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function SetMapMode Lib "gdi32" (ByVal hDC As Long, ByVal nMapMode As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function GradientFillRect Lib "msimg32" Alias "GradientFill" (ByVal hDC As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long
    Private Declare Function DrawFrameControl Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal un1 As Long, ByVal un2 As Long) As Long
    Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare Function IsWindowEnabled Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT, ByVal bErase As Long) As Long


    Private lPrevWinProc As Long, lHook As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

'API Constants.
Private Const WH_CBT As Long = 5
Private Const GWL_WNDPROC As Long = -4
Private Const GCL_STYLE = -26
Private Const GWL_STYLE As Long = (-16)
Private Const HCBT_ACTIVATE As Long = 5
Private Const WM_ACTIVATE As Long = &H6
Private Const WM_EXITSIZEMOVE As Long = &H232
Private Const WM_DESTROY As Long = &H2
Private Const WM_SYSCOMMAND = &H112
Private Const WM_NCPAINT = &H85
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const WS_SYSMENU = &H80000
Private Const SM_CXSIZE = 30
Private Const SM_CYSIZE = 31
Private Const DFCS_PUSHED = &H200
Private Const CS_DROPSHADOW = &H20000
Private Const DFC_CAPTION = 1
Private Const DFCS_CAPTIONCLOSE = &H0
Private Const SM_CYCAPTION As Long = 4
Private Const COLOR_ACTIVECAPTION = 2
Private Const GRADIENT_FILL_RECT_H As Long = &H0
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2

'Module level variables.
Private oForm As Object
Private tWinRect As RECT
Private tCloseRect As RECT
Private tUpdatedCloseButtonRect As RECT
Private sFontName As String
Private sCaptionText As String
Private bDrawn As Boolean
Private bDropShadow As Boolean
Private bHookEnabled As Boolean
Private bGradientFill As Boolean
Private bFontBold As Boolean
Private bFontItalic As Boolean
Private bFontUnderline As Boolean
Private bCloseButtonPressed As Boolean
Private lTitleBarColor As Long
Private lFontColor  As Long
Private lFontSize As Long


Public Sub FormatFormCaption( _
    ByVal Form As Object, _
    Optional ByVal TitleBarColor As Variant, _
    Optional ByVal GradientFill As Boolean, _
    Optional ByVal DropShadow As Boolean, _
    Optional ByVal FontName As String, _
    Optional ByVal FontColor As Long, _
    Optional ByVal FontSize As Long, _
    Optional ByVal FontBold As Boolean, _
    Optional ByVal FontItalic As Boolean, _
    Optional ByVal FontUnderline As Boolean _
)

    Call HookUserForm(ByVal Form, _
        ByVal TitleBarColor, _
        ByVal GradientFill, _
        ByVal DropShadow, _
        ByVal FontName, _
        ByVal FontColor, _
        ByVal FontSize, _
        ByVal FontBold, _
        ByVal FontItalic, _
        ByVal FontUnderline _
    )
End Sub

Private Sub HookUserForm( _
    ByVal Form As Object, _
    Optional ByVal TitleBarColor As Variant, _
    Optional ByVal GradientFill As Boolean, _
    Optional ByVal DropShadow As Boolean, _
    Optional ByVal FontName As String, _
    Optional ByVal FontColor As Long, _
    Optional ByVal FontSize As Long, _
    Optional ByVal FontBold As Boolean, _
    Optional ByVal FontItalic As Boolean, _
    Optional ByVal FontUnderline As Boolean _
)

    If Not bHookEnabled Then
        Set oForm = Form
        sCaptionText = Form.Caption
        bGradientFill = GradientFill
        If IsMissing(TitleBarColor) Then
            lTitleBarColor = GetSysColor(COLOR_ACTIVECAPTION)
        Else
            lTitleBarColor = TitleBarColor
        End If
        bDropShadow = DropShadow
        sFontName = FontName
        lFontColor = FontColor
        lFontSize = FontSize
        bFontBold = FontBold
        bFontItalic = FontItalic
        bFontUnderline = FontUnderline
        lHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId)
        bHookEnabled = True
    Else
        UnhookWindowsHookEx lHook
        MsgBox "The hook is already set.", vbInformation
    End If
End Sub

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function HookProc(ByVal idHook As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Dim hwnd As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function HookProc(ByVal idHook As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim hwnd As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    If idHook = HCBT_ACTIVATE Then
        If IsWindowEnabled(GetParent(wParam)) Then
            UnhookWindowsHookEx lHook
            Call ResetVariables
            MsgBox "You can't format a Modeless Userform.", vbCritical
            Exit Function
        End If
        WindowFromAccessibleObject oForm, hwnd
        If hwnd = wParam Then
            lPrevWinProc = SetWindowLong(wParam, GWL_WNDPROC, AddressOf CallBackProc)
            bHookEnabled = False
            UnhookWindowsHookEx lHook
        End If
    End If
    HookProc = CallNextHookEx(lHook, idHook, ByVal wParam, ByVal lParam)
End Function
 
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function CallBackProc(ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function CallBackProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
 
    Dim tPt As POINTAPI, tClientRect As RECT
    Dim loword As Long, hiword As Long
                    
    GetClientRect hwnd, tClientRect
    
    Select Case Msg
     
        Case WM_NCLBUTTONDOWN
            SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE + SWP_NOMOVE
        
        Case WM_ACTIVATE
            If wParam = 0 Then SetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOSIZE + SWP_NOMOVE
            SetWindowLong hwnd, GWL_STYLE, (GetWindowLong(hwnd, GWL_STYLE) And Not WS_SYSMENU)
            Call DrawTitleBar(hwnd, lTitleBarColor)
            InvalidateRect hwnd, tClientRect, 0
            
        Case WM_EXITSIZEMOVE
            Call DrawTitleBar(hwnd, lTitleBarColor)
            InvalidateRect hwnd, tClientRect, 0
            
        Case WM_NCPAINT
            If bDrawn = False Then bDrawn = True: Call DrawTitleBar(hwnd, lTitleBarColor)
            Exit Function
            
        Case WM_SYSCOMMAND
            GetHiLoword CLng(lParam), loword, hiword
            tPt.x = loword
            tPt.y = hiword
            [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
                Dim lngPtr As LongPtr
                [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
                    CopyMemory lngPtr, tPt, LenB(tPt)
                    If PtInRect(tUpdatedCloseButtonRect, lngPtr) Then
                [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
                    If PtInRect(tUpdatedCloseButtonRect, tPt.x, tPt.y) Then
                [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
            [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
                If PtInRect(tUpdatedCloseButtonRect, tPt.x, tPt.y) Then
            [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
            
                Call DrawTitleBar(hwnd, lTitleBarColor, True)
                Do
                    DoEvents
                Loop Until GetAsyncKeyState(vbKeyLButton) = 0
    
                GetCursorPos tPt
                [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
                    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
                        CopyMemory lngPtr, tPt, LenB(tPt)
                        If PtInRect(tUpdatedCloseButtonRect, lngPtr) Then
                    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
                        If PtInRect(tUpdatedCloseButtonRect, tPt.x, tPt.y) Then
                    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
                [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
                    If PtInRect(tUpdatedCloseButtonRect, tPt.x, tPt.y) Then
                [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
                        If bCloseButtonPressed Then Sleep 200
                        Unload oForm
                    End If
                End If
                
                If bCloseButtonPressed Then
                    Call DrawTitleBar(hwnd, lTitleBarColor)
                    InvalidateRect hwnd, tClientRect, 0
                End If
                
        Case WM_DESTROY
            SetWindowLong hwnd, GWL_WNDPROC, lPrevWinProc
            SetClassLong hwnd, GCL_STYLE, GetClassLong(hwnd, GCL_STYLE) And Not CS_DROPSHADOW
            Call ResetVariables
    End Select
    
    CallBackProc = CallWindowProc(lPrevWinProc, hwnd, Msg, wParam, ByVal lParam)
End Function
 
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Sub DrawTitleBar(hwnd As LongPtr, ByVal CaptionColor As Long, Optional ByVal PressedCloseButton As Boolean)
    Dim hdc As LongPtr, hBrush As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Sub DrawTitleBar(hwnd As Long, ByVal CaptionColor As Long, Optional ByVal PressedCloseButton As Boolean)
    Dim hdc As Long, hBrush As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
 
    Dim p1 As POINTAPI, p2 As POINTAPI
    Dim tFormRect As RECT, tFillRect As RECT
    Dim tPs As PAINTSTRUCT, tLb As LOGBRUSH
    Dim vert(2) As TRIVERTEX, tPt As GRADIENT_RECT
    Dim r As Byte, G As Byte, B As Byte
    
    Call BeginPaint(hwnd, tPs)
        hdc = GetWindowDC(hwnd)
        tLb.lbColor = CaptionColor
        hBrush = CreateBrushIndirect(tLb)
        Call GetWindowRect(hwnd, tFormRect)
        
        bCloseButtonPressed = PressedCloseButton
            
        If Not PressedCloseButton Then
            If bGradientFill Then
                ConvertLongToRGB CaptionColor, r, G, B
                With vert(0)
                    .x = 0
                    .y = 0
                    .Red = TransfCol(r)
                    .Green = TransfCol(G)
                    .Blue = TransfCol(B)
                    .Alpha = TransfCol(0)
                End With
                With vert(1)
                    .x = tFormRect.Right - tFormRect.Left
                    .y = GetSystemMetrics(SM_CYSIZE) + (tFormRect.Bottom - tFormRect.Top)
                    .Red = TransfCol(0)
                    .Green = TransfCol(0)
                    .Blue = TransfCol(0)
                    .Alpha = TransfCol(0)
                End With
                tPt.UpperLeft = 0
                tPt.LowerRight = 1
                GradientFillRect hdc, vert(0), 2, tPt, 1, GRADIENT_FILL_RECT_H
            Else
                SetRect tFormRect, 0, 0, tFormRect.Right, tFormRect.Bottom
                SetRect tFillRect, 0, 5, GetSystemMetrics(SM_CXSIZE), GetSystemMetrics(SM_CYSIZE) + tFormRect.Bottom
                OffsetRect tFillRect, tWinRect.Right - tWinRect.Left - GetSystemMetrics(SM_CXSIZE), 0
                FillRect hdc, tFormRect, hBrush
                Call DeleteObject(hBrush)
            End If
            DrawFrameControl hdc, tCloseRect, DFC_CAPTION, DFCS_CAPTIONCLOSE
        Else
            DrawFrameControl hdc, tCloseRect, DFC_CAPTION, DFCS_CAPTIONCLOSE + DFCS_PUSHED
        End If
        
        If bDropShadow Then
            SetClassLong hwnd, GCL_STYLE, GetClassLong(hwnd, GCL_STYLE) Or CS_DROPSHADOW
        End If
        
        SetBkMode hdc, 1
        SetTextColor hdc, lFontColor
        Call CreateFont(hdc)
        TextOut hdc, 4, 4, sCaptionText, Len(sCaptionText)
            
        GetClientRect hwnd, tCloseRect
        With tCloseRect
            .Bottom = GetSystemMetrics(SM_CYCAPTION)
            .Left = .Right - 20
            .Right = .Right + 3
            .Top = .Top + 4
        End With
        With tCloseRect
            p1.x = .Left - 2: p1.y = .Top - 2
            p2.x = .Right:  p2.y = .Bottom - GetSystemMetrics(SM_CYCAPTION) - 2
        End With
        ClientToScreen hwnd, p1
        ClientToScreen hwnd, p2
        With tUpdatedCloseButtonRect
            .Left = p1.x: .Top = p1.y - GetSystemMetrics(SM_CYCAPTION)
            .Right = p2.x:  .Bottom = p2.y
        End With
        ReleaseDC hwnd, hdc
    Call EndPaint(hwnd, tPs)
End Sub

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Sub CreateFont(DC As LongPtr)
    Dim hNewFont As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Sub CreateFont(DC As Long)
    Dim hNewFont As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
    Dim tFont As LOGFONT
    
    With tFont
        .lfFaceName = sFontName & Chr$(0)
        .lfWidth = lFontSize
        .lfWeight = IIf(bFontBold, 900, 100)
        .lfItalic = bFontItalic
        .lfUnderline = bFontUnderline
    End With
    hNewFont = CreateFontIndirect(tFont)
    DeleteObject (SelectObject(DC, hNewFont))
End Sub

Private Sub ResetVariables()
    bHookEnabled = False
    bCloseButtonPressed = False
    bDrawn = False
    bGradientFill = False
    bDropShadow = False
    sFontName = vbNullString
    lFontSize = 0
    bFontBold = False
    bFontItalic = False
    bFontUnderline = False
    sCaptionText = vbNullString
    lTitleBarColor = 0
    lFontColor = 0
    Set oForm = Nothing
End Sub

Private Sub GetHiLoword(lParam As Long, ByRef loword As Long, ByRef hiword As Long)
    loword = lParam And &HFFFF&
    hiword = lParam \ &H10000 And &HFFFF&
End Sub

Private Sub ConvertLongToRGB(ByVal Value As Long, r As Byte, G As Byte, B As Byte)
    r = Value Mod 256
    G = Int(Value / 256) Mod 256
    B = Int(Value / 256 / 256) Mod 256
End Sub

Private Function TransfCol(ByVal Col As Long) As Double
    Dim a As Double
    
    If Col = 0 Then
        TransfCol = 0
    ElseIf Col > 127 Then
        a = 256 - Col
        TransfCol = -(256 * a)
    Else
        a = Col
        TransfCol = 256 * a
    End If
End Function

2- Usage example (code in the UserForm Module)

Option Explicit

Private Sub UserForm_Initialize()

    Call FormatFormCaption( _
        Form:=Me, _
        TitleBarColor:=vbCyan, _
        GradientFill:=True, _
        DropShadow:=True, _
        FontName:="MV Boli", _
        FontColor:=vbRed, _
        FontSize:=12, _
        FontBold:=True, _
        FontItalic:=True, _
        FontUnderline:=False _
    )


End Sub

The image below doesn't show the shadow visual effect clearly.. You will need to download the demo workbook in the above link to see it.

 

[hymced]

Hello Jaafar,
Coming back a little bit late maybe, but I have just tested your demo workbook with Excel version 1902 (Office 32-bit 16.0.11328.20158) on Windows 10 64-bit :

not working

 

[Jaafar Tribak]

Hello Jaafar,
Coming back a little bit late maybe, but I have just tested your demo workbook with Excel version 1902 (Office 32-bit 16.0.11328.20158) on Windows 10 64-bit

Not sure why it didn't work ... Maybe there is a incorrect API declaration.

I don't have a 32bit edition of excel so I can't test it but I'll look into later and post back if anything comes up.

 

[YasserKhalil]

Hello Jaafar
The same as hymced's problem. I have office 32Bit installed on Windows 10 64Bit

 

[Jaafar Tribak]

Hello Jaafar
The same as hymced's problem. I have office 32Bit installed on Windows 10 64Bit

Hi Yasser - How are you .

I'll take a look at this later on a different machine and will let you know.

Regards.

 

[RoryA]

FYI, it works on Win7 64bit with Office 2010 32bit.

 

[YasserKhalil]

Thank you very much my friend.
Kind Regards