Drawing on UserForm Title-Bar and adding some cool formatting

Jaafar Tribak · Jan 28, 2020

Hi dear forum,

I am posting here some code that I have been working on in recent days. The code allows users to apply the following cool-looking niceties to their userforms:

1- Change the color of the Non-Client Area and optionally, add a gradient fill.
2- Change the Font of the caption text , its color, size ...etc.
3- Add a frame shadow.
4- Add an icon on titlebar.

I made a similar attempt a while back wich I posted here but the code was incomplete and didn't work on some computers - I hope this one does.

Because the code subclasses the userform, I added a safety routine to prevent potential crashings should an unhandled run-time error occur.

Workbook Demo.

1- Main API Code in a Standard Module :

VBA Code:

Option Explicit
 
' Jaafar Tribak @ MrExcel.com on 26/01/20
' Formatting/Drawing on (Non-Client area) of vba Userforms.

' USAGE
' =====
        ' 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, _
            Optional ByVal IconFile As String _
        )



' 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 GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    #If VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    #Else
       hPic As Long
       hPal As Long
    #End If
End Type

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    #If VBA7 Then
        bmBits As LongPtr
    #Else
        bmBits As Long
    #End If
End Type

Private Type ICONINFO
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    #If VBA7 Then
        hbmMask As LongPtr
        hbmColor As LongPtr
    #Else
        hbmMask As Long
        hbmColor As Long
    #End If
End Type
 
Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
     #If VBA7 Then
        lbHatch As LongPtr
    #Else
        lbHatch As Long
    #End If
End Type

Private Type PAINTSTRUCT
    #If VBA7 Then
        hdc As LongPtr
    #Else
        hdc As Long
    #End 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.
#If VBA7 Then
    #If 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
    #Else
        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
    #End 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 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 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 GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) 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 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 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 Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function GetDCEx Lib "user32" (ByVal hwnd As LongPtr, ByVal hrgnclip As LongPtr, ByVal fdwOptions As Long) As LongPtr
    Private Declare PtrSafe Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function Rectangle Lib "gdi32" (ByVal hdc As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare PtrSafe Function RedrawWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal lprcUpdate As Long, ByVal hrgnUpdate As LongPtr, ByVal fuRedraw As Long) As Long
    Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) 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 GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As LongPtr, ByVal dwId As Long, ByVal riid As LongPtr, ppvObject As Any) As Long
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
    Private Declare PtrSafe Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
    Private Declare PtrSafe Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare PtrSafe Function DrawIcon Lib "user32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long, ByVal hIcon As LongPtr) As Long
    Private Declare PtrSafe Function SetGraphicsMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal iMode As Long) As Long
    Private Declare PtrSafe Function LPtoDP Lib "gdi32" (ByVal hdc As LongPtr, lpPoint As POINTAPI, ByVal nCount As Long) As Long
    Private Declare PtrSafe Function GetIconInfo Lib "user32" (ByVal hIcon As LongPtr, piconinfo As ICONINFO) As Long
    Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare PtrSafe Function CreatePopupMenu Lib "user32" () As LongPtr
    Private Declare PtrSafe Function DestroyMenu Lib "user32" (ByVal hMenu As LongPtr) As Long
    Private Declare PtrSafe Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As LongPtr, ByVal wFlags As Long, ByVal wIDNewItem As LongPtr, ByVal lpNewItem As Any) As Long
    Private Declare PtrSafe Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As LongPtr, ByVal un As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal hwnd As LongPtr, ByVal lpTPMParams As Long) As Long
    Private Declare PtrSafe Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As LongPtr, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As LongPtr, ByVal hBitmapChecked As LongPtr) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleaut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
    Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long

    Private lHook As LongPtr
#Else

    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 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 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 GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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 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 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 Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function GetDCEx Lib "user32" (ByVal hwnd As Long, ByVal hrgnclip As Long, ByVal fdwOptions As Long) As Long
    Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
    Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, ByVal lprcUpdate As Long, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
    Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare Function AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As Long, ByVal dwId As Long, ByVal riid As Long, ppvObject As Any) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, ByVal lpiid As Long) As Long
    Private Declare Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
    Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
    Private Declare Function SetGraphicsMode Lib "gdi32" (ByVal hdc As Long, ByVal iMode As Long) As Long
    Private Declare Function LPtoDP Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
    Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare Function CreatePopupMenu Lib "user32" () As Long
    Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
    Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
    Private Declare Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As Long, ByVal un As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal hwnd As Long, ByVal lpTPMParams As Long) As Long
    Private Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
    Private Declare Function OleCreatePictureIndirectAut Lib "oleaut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
    Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long

    Private lHook As Long
#End If


' API Constants.
Private Const WH_CBT = 5
Private Const GWL_WNDPROC = -4
Private Const GCL_STYLE = -26
Private Const GWL_STYLE = (-16)
Private Const HCBT_CREATEWND = &H3
Private Const HCBT_ACTIVATE = 5
Private Const WM_ACTIVATE = &H6
Private Const WM_EXITSIZEMOVE = &H232
Private Const WM_ENTERSIZEMOVE = &H231
Private Const WM_DESTROY = &H2
Private Const WM_NCPAINT = &H85
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const WM_CANCELMODE = &H1F
Private Const WM_ENABLE = &HA
Private Const WM_ACTIVATEAPP = &H1C
Private Const WM_GETICON = &H7F
Private Const WM_NCRBUTTONDOWN = &HA4
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 DFCS_HOT = &H1000
Private Const COLOR_ACTIVECAPTION = 2
Private Const GRADIENT_FILL_RECT_H = &H0
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_FRAMECHANGED = &H20
Private Const DCX_WINDOW = &H1&
Private Const DCX_CACHE = &H2&
Private Const DCX_INTERSECTRGN = &H80&
Private Const DCX_LOCKWINDOWUPDATE = &H400&
Private Const PS_SOLID = 0
Private Const RDW_UPDATENOW = &H100
Private Const RDW_INVALIDATE = &H1
Private Const RDW_ALLCHILDREN = &H80
Private Const MF_STRING = &H0&
Private Const TPM_RETURNCMD = &H100&
Private Const WM_SETCURSOR = &H20
Private Const LR_LOADFROMFILE = &H10
Private Const MM_LOMETRIC = 2
Private Const GM_ADVANCED = 2
Private Const MF_BYPOSITION = &H400
Private Const LR_COPYRETURNORG = &H4
Private Const CF_BITMAP = 2
Private Const IMAGE_BITMAP = 0
Private Const PICTYPE_BITMAP = 1
Private Const S_OK = &H0
Private Const OBJID_SELF = &H0&


' Private Module level variables.
Private bHookEnabled As Boolean
Private oForm As Object
Private bSubclassed As Boolean
Private lWidth As Long, lHeight As Long
Private lft As Long, ltp As Long


' Public Module level variables.
Public lTitleBarColor As Long
Public sFontName As String
Public sCaptionText As String
Public bGradientFill As Boolean
Public bDropShadow As Boolean
Public bFontBold As Boolean
Public bFontItalic As Boolean
Public bFontUnderline As Boolean
Public lFontColor  As Long
Public lFontSize As Long
Public sIconFilePath As String
Public lCaptionTitleOffset As Long





'________________________________________ Public Routines ___________________________________________________________

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, _
    Optional ByVal IconFile As String _
)

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


Public Sub UpdateForm()
    
    Call SetWindowPos(GetProp(Application.hwnd, "hForm"), 0, 0, 0, 0, 0, SWP_FRAMECHANGED Or SWP_NOSIZE Or SWP_NOMOVE)

End Sub





'________________________________________ Private Routines ___________________________________________________________

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, _
    Optional ByVal IconFile _
)

    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
        If Len(IconFile) Then sIconFilePath = IconFile
        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


Private Sub SubClassForm(ByVal Subclass As Boolean)

    If Subclass Then
       Call SetProp(Application.hwnd, "FormPrevProc", SetWindowLong(GetProp(Application.hwnd, "hForm"), GWL_WNDPROC, AddressOf WindowProc))
       bSubclassed = True
    Else
        Call SetWindowLong(GetProp(Application.hwnd, "hForm"), GWL_WNDPROC, GetProp(Application.hwnd, "FormPrevProc"))
        bSubclassed = False
    End If

End Sub


#If VBA7 Then
    Private Function HookProc(ByVal idHook As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Dim hwnd As LongPtr, hCBT As LongPtr
#Else
    Private Function HookProc(ByVal idHook As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim hwnd As Long, hCBT As Long
#End If

    If idHook = HCBT_ACTIVATE Then
        If IsWindowEnabled(GetParent(wParam)) Then
            UnhookWindowsHookEx lHook
            MsgBox "You can't format a Modeless Userform.", vbCritical
            Exit Function
        End If
        WindowFromAccessibleObject oForm, hwnd
        If hwnd = wParam Then
            bHookEnabled = False
            UnhookWindowsHookEx lHook
            SetProp Application.hwnd, "hForm", wParam
            hCBT = SetWindowsHookEx(WH_CBT, AddressOf CatchErrorFunc, 0, GetCurrentThreadId)
            SetProp Application.hwnd, "hCBT", hCBT
            Call SubClassForm(True)
        End If
        
    End If

    HookProc = CallNextHookEx(lHook, idHook, ByVal wParam, ByVal lParam)
    
End Function


#If VBA7 Then
    Private Function WindowProc(ByVal hwnd As LongPtr, ByVal MSG As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
        Dim hdc As LongPtr, hPen As LongPtr, hBrush As LongPtr, hRgn As LongPtr, hTempCursor As LongPtr, hMenu As LongPtr, lngPtr As LongPtr
#Else
    Private Function WindowProc(ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
        Dim hdc As Long, hPen As Long, hBrush As Long, hRgn As Long, hTempCursor As Long, hMenu As Long
#End If

    Static bEnable As Boolean
    Static bActivatingApp As Boolean
    Static lpPoint(0) As POINTAPI
    Static tCloseXRect As RECT
    
    Dim tWinRect As RECT, tClientRect As RECT, UpdCloseX As RECT
    Dim tPt1 As POINTAPI, tPt2 As POINTAPI, tCurPos As POINTAPI
    Dim vert(2) As TRIVERTEX, tPt As GRADIENT_RECT
    Dim tLb As LOGBRUSH, R As Byte, G As Byte, B As Byte
    Dim lPrevMapMode As Long, lPrevGrraphicMode As Long
    Dim oFaceIdPic1 As StdPicture, lShowPopupMenu As Long
 


    Call GetWindowRect(hwnd, tWinRect)
    Call GetClientRect(hwnd, tClientRect)
    
    Select Case MSG
    
        Case WM_NCPAINT
        
            With tWinRect
                hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
            End With
            
            hdc = GetDCEx(hwnd, IIf(wParam = 1, hRgn, wParam), DCX_WINDOW Or DCX_CACHE Or _
            DCX_INTERSECTRGN Or DCX_LOCKWINDOWUPDATE)
            
            tLb.lbColor = lTitleBarColor
            hBrush = CreateBrushIndirect(tLb)
            ConvertLongToRGB lTitleBarColor, 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 = tWinRect.Right - tWinRect.Left
                .y = GetSystemMetrics(SM_CYSIZE) + (tWinRect.Bottom - tWinRect.Top)
                .Red = IIf(bGradientFill, 0, TransfCol(R))
                .Green = IIf(bGradientFill, 0, TransfCol(G))
                .Blue = IIf(bGradientFill, 0, TransfCol(B))
                .alpha = TransfCol(0)
            End With
            tPt.UpperLeft = 0
            tPt.LowerRight = 1
            GradientFillRect hdc, vert(0), 2, tPt, 1, GRADIENT_FILL_RECT_H
            DeleteObject SelectObject(hdc, hBrush)
            
            
            If bGradientFill = False Then
                hPen = CreatePen(PS_SOLID, 2, RGB(90, 90, 90))
                DeleteObject SelectObject(hdc, hPen)
                Call Rectangle(hdc, 0, 0, (tWinRect.Right - tWinRect.Left), (tWinRect.Bottom - tWinRect.Top))
            End If
            
            If bDropShadow Then
                If GetClassLong(hwnd, GCL_STYLE) Or CS_DROPSHADOW Then
                    SetClassLong hwnd, GCL_STYLE, GetClassLong(hwnd, GCL_STYLE) And Not CS_DROPSHADOW
                End If
            Else
                If GetClassLong(hwnd, GCL_STYLE) And Not CS_DROPSHADOW Then
                    SetClassLong hwnd, GCL_STYLE, GetClassLong(hwnd, GCL_STYLE) Or CS_DROPSHADOW
                End If
            End If
            
            If bDropShadow Then
                SetClassLong hwnd, GCL_STYLE, GetClassLong(hwnd, GCL_STYLE) Or CS_DROPSHADOW
            Else
                SetClassLong hwnd, GCL_STYLE, GetClassLong(hwnd, GCL_STYLE) And Not CS_DROPSHADOW
            End If
            
            With tCloseXRect
                .Left = lft
                .Top = ltp
                .Right = lft + lWidth
                .Bottom = ltp + lHeight
            End With
            
            DrawFrameControl hdc, tCloseXRect, DFC_CAPTION, DFCS_CAPTIONCLOSE
            
            If Len(sIconFilePath) Then
                hTempCursor = LoadImage(0, sIconFilePath, 1, 0, 0, LR_LOADFROMFILE)
                If hTempCursor Then
                    DrawIcon hdc, GetSystemMetrics(7) + GetSystemMetrics(32), 0, hTempCursor
                    lPrevMapMode = SetMapMode(hdc, MM_LOMETRIC)
                    lPrevGrraphicMode = SetGraphicsMode(hdc, GM_ADVANCED)
                    lpPoint(0).x = IconSize(hTempCursor).x + 40
                    LPtoDP hdc, lpPoint(0), 1
                    Call SetGraphicsMode(hdc, lPrevGrraphicMode)
                    Call SetMapMode(hdc, lPrevMapMode)
                End If
            End If
            
            SetBkMode hdc, 1
            SetTextColor hdc, lFontColor
            Call CreateFont(hdc)
            If hTempCursor Then
                TextOut hdc, lpPoint(0).x + lCaptionTitleOffset, 4, sCaptionText, Len(sCaptionText)
            Else
                TextOut hdc, GetSystemMetrics(7) + GetSystemMetrics(32) + lCaptionTitleOffset, 4, sCaptionText, Len(sCaptionText)
            End If

            oForm.Repaint
            Call RedrawWindow(hwnd, 0, IIf(wParam = 1, hRgn, wParam), RDW_UPDATENOW + RDW_INVALIDATE + RDW_ALLCHILDREN)
            InvalidateRect hwnd, tClientRect, 0
            
            ReleaseDC hwnd, hdc
            DeleteObject (hRgn)
            DeleteObject (hPen)
            DeleteObject (hBrush)
            Exit Function
        
        
        Case WM_GETICON
        
            If bEnable Then
                bEnable = False
                Call SetWindowPos(hwnd, 0, 0, 0, 0, 0, SWP_FRAMECHANGED Or SWP_NOSIZE Or SWP_NOMOVE)
            End If
            
            
        Case WM_ACTIVATEAPP
        
            bActivatingApp = True
        
        
        Case WM_ACTIVATE
        
            If bEnable = False And bActivatingApp = False Then
                bActivatingApp = True
                lft = GetXButtonRect.Left: ltp = GetXButtonRect.Top
                lWidth = GetXButtonRect.Right - GetXButtonRect.Left
                lHeight = GetXButtonRect.Bottom - GetXButtonRect.Top
                SetWindowLong hwnd, GWL_STYLE, (GetWindowLong(hwnd, GWL_STYLE) And Not WS_SYSMENU)
            Else
                Call SetWindowLong(hwnd, GWL_STYLE, (GetWindowLong(hwnd, GWL_STYLE) And Not WS_SYSMENU))
                Call SetWindowPos(hwnd, 0, 0, 0, 0, 0, SWP_FRAMECHANGED Or SWP_NOSIZE Or SWP_NOMOVE)
            End If
            
        
        Case WM_NCLBUTTONDOWN, WM_SETCURSOR
        
            With tWinRect
                hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
            End With
            
            hdc = GetDCEx(hwnd, hRgn, DCX_WINDOW Or DCX_CACHE Or _
            DCX_INTERSECTRGN Or DCX_LOCKWINDOWUPDATE)
            
            With tCloseXRect
                tPt1.x = .Left - lWidth / 3: tPt1.y = .Top - lHeight * GetSystemMetrics(4)
                tPt2.x = .Right - lWidth / 3
                ClientToScreen hwnd, tPt1
                ClientToScreen hwnd, tPt2
                UpdCloseX.Left = tPt1.x: UpdCloseX.Top = tPt1.y
                UpdCloseX.Right = tPt2.x: UpdCloseX.Bottom = tPt2.y
            End With
            
            GetCursorPos tCurPos
            
            #If Win64 Then
                CopyMemory lngPtr, tCurPos, LenB(tCurPos)
            If PtInRect(UpdCloseX, lngPtr) Then
            #Else
                If PtInRect(UpdCloseX, tCurPos.x, tCurPos.y) Then
            #End If
                    If MSG = WM_NCLBUTTONDOWN Then
                        DrawFrameControl hdc, tCloseXRect, DFC_CAPTION, DFCS_CAPTIONCLOSE + DFCS_PUSHED + DFCS_HOT
                    ElseIf MSG = WM_SETCURSOR Then
                        DrawFrameControl hdc, tCloseXRect, DFC_CAPTION, DFCS_CAPTIONCLOSE + DFCS_HOT
                    End If
                    If MSG = WM_NCLBUTTONDOWN Then
                        Sleep 400
                        Unload oForm
                    End If
                Else
                    DrawFrameControl hdc, tCloseXRect, DFC_CAPTION, DFCS_CAPTIONCLOSE
                End If
                
            ReleaseDC hwnd, hdc
            DeleteObject (hRgn)
        
        
        Case WM_ENABLE
        
            bEnable = True
            If wParam Then
                Call SetWindowPos(hwnd, 0, 0, 0, 0, 0, SWP_FRAMECHANGED Or SWP_NOSIZE Or SWP_NOMOVE)
            End If
            
        
        Case WM_CANCELMODE
        
            Call SetWindowPos(hwnd, 0, 0, 0, 0, 0, SWP_FRAMECHANGED Or SWP_NOSIZE Or SWP_NOMOVE)
                                              
        
        Case WM_NCRBUTTONDOWN
        
            GetCursorPos tCurPos
            With tCloseXRect
                tPt1.x = .Left - lWidth / 3: tPt1.y = .Top - lHeight * GetSystemMetrics(4)
                tPt2.x = .Right - lWidth / 3
                ClientToScreen hwnd, tPt1
                ClientToScreen hwnd, tPt2
                UpdCloseX.Left = tPt1.x: UpdCloseX.Top = tPt1.y
                UpdCloseX.Right = tPt2.x: UpdCloseX.Bottom = tPt2.y
            End With
            
            #If Win64 Then
                CopyMemory lngPtr, tCurPos, LenB(tCurPos)
                If PtInRect(UpdCloseX, lngPtr) = 0 Then
            #Else
                If PtInRect(UpdCloseX, tCurPos.x, tCurPos.y) = 0 Then
            #End If
                    hMenu = CreatePopupMenu()
                    Call AppendMenu(hMenu, MF_STRING, 1, "&Close")
                    Set oFaceIdPic1 = PicFromFaceID(478)
                    If Not oFaceIdPic1 Is Nothing Then
                        Call SetMenuItemBitmaps(hMenu, 0, MF_BYPOSITION, oFaceIdPic1, oFaceIdPic1)
                    End If
                    lShowPopupMenu = TrackPopupMenuEx(hMenu, TPM_RETURNCMD, tCurPos.x, tCurPos.y, hwnd, ByVal 0&)
                    If lShowPopupMenu = 1 Then
                        Call DestroyMenu(hMenu)
                        Unload oForm
                        Exit Function
                    End If
                    Call DestroyMenu(hMenu)
                    Exit Function
                End If
                
        
        Case WM_DESTROY
        
            
            If bDropShadow Then
                If GetClassLong(hwnd, GCL_STYLE) Or CS_DROPSHADOW Then
                    SetClassLong hwnd, GCL_STYLE, GetClassLong(hwnd, GCL_STYLE) And Not CS_DROPSHADOW
                End If
            Else
                If GetClassLong(hwnd, GCL_STYLE) And Not CS_DROPSHADOW Then
                    SetClassLong hwnd, GCL_STYLE, GetClassLong(hwnd, GCL_STYLE) Or CS_DROPSHADOW
                End If
            End If
            
            bActivatingApp = False
            bEnable = False
            UnhookWindowsHookEx GetProp(Application.hwnd, "hCBT")
            Call SubClassForm(False)
            Call ResetVariables
    
    End Select
    
    WindowProc = CallWindowProc(GetProp(Application.hwnd, "FormPrevProc"), hwnd, MSG, wParam, ByVal lParam)

End Function


Private Sub ResetVariables()

    bHookEnabled = False
    bSubclassed = False
    bGradientFill = False
    bDropShadow = False
    sFontName = vbNullString
    lFontSize = 0
    bFontBold = False
    bFontItalic = False
    bFontUnderline = False
    sCaptionText = vbNullString
    sIconFilePath = vbNullString
    lTitleBarColor = 0
    lFontColor = 0
    lCaptionTitleOffset = 0
    lWidth = 0: lHeight = 0
    Call RemoveProp(Application.hwnd, "hForm")
    Call RemoveProp(Application.hwnd, "FormPrevProc")
    Set oForm = Nothing
    
End Sub


Private Function GetXButtonRect() As RECT

    Dim tGUID(0 To 3) As Long
    Dim oIAc As IAccessible, vIacc As Variant
    Dim pxLeft As Long, pxTop As Long, pxWidth As Long, pxHeight As Long
 
    On Error Resume Next

    If IIDFromString(StrPtr("{618736E0-3C3D-11CF-810C-00AA00389B71}"), VarPtr(tGUID(0))) = S_OK Then
        If AccessibleObjectFromWindow(GetProp(Application.hwnd, "hForm"), OBJID_SELF, VarPtr(tGUID(0)), oIAc) = S_OK Then
            Set vIacc = oIAc
            AccessibleChildren vIacc, 1, 1, vIacc, 1
            Call vIacc.accLocation(pxLeft, pxTop, pxWidth, pxHeight, 5&)
            With GetXButtonRect
                .Left = pxLeft: .Top = pxTop
                .Right = pxLeft + pxWidth: .Bottom = pxTop + pxHeight
            End With
        End If
    End If
    
End Function


#If VBA7 Then
    Private Function IconSize(ByVal hIcon As LongPtr) As POINTAPI
#Else
    Private Function IconSize(ByVal hIcon As Long) As POINTAPI
#End If

    Dim IconInf As ICONINFO, BMInf As BITMAP, BitDepth As Integer
    
    If (GetIconInfo(hIcon, IconInf)) Then
        If (IconInf.hbmColor) Then
            If (GetObjectAPI(IconInf.hbmColor, LenB(BMInf), BMInf)) Then
                IconSize.x = BMInf.bmWidth
                IconSize.y = BMInf.bmHeight
                BitDepth = BMInf.bmBitsPixel
            End If
            Call DeleteObject(IconInf.hbmColor)
        Else
            If (GetObjectAPI(IconInf.hbmMask, LenB(BMInf), BMInf)) Then
                IconSize.x = BMInf.bmWidth
                IconSize.y = BMInf.bmHeight \ 2
                BitDepth = 1
            End If
        End If
        Call DeleteObject(IconInf.hbmMask)
    End If

End Function


#If VBA7 Then
    Private Sub CreateFont(DC As LongPtr)
    Dim hNewFont As LongPtr
#Else
    Private Sub CreateFont(DC As Long)
    Dim hNewFont As Long
#End 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 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


Private Function PicFromFaceID(ByVal FaceID As Long) As IPicture

    #If VBA7 Then
        Dim hPtr As LongPtr, hLib As LongPtr
    #Else
        Dim hPtr As Long, hLib As Long
    #End If

    Dim IID_IDispatch As GUID, uPicinfo As uPicDesc
    Dim iPic As IPicture, lRet As Long, lPictype As Long
    
    On Error GoTo errHandler
            
    Application.CommandBars.FindControl(ID:=FaceID).CopyFace
    Call OpenClipboard(0)
    hPtr = GetClipboardData(CF_BITMAP)
    hPtr = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
    EmptyClipboard
    CloseClipboard
    lPictype = PICTYPE_BITMAP
    
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With uPicinfo
        .Size = Len(uPicinfo)
        .Type = lPictype
        .hPic = hPtr
        .hPal = 0
    End With
    hLib = LoadLibrary("oleAut32.dll")
    If hLib Then
        lRet = OleCreatePictureIndirectAut(uPicinfo, IID_IDispatch, True, iPic)
    Else
        lRet = OleCreatePictureIndirectPro(uPicinfo, IID_IDispatch, True, iPic)
    End If
    
    Call FreeLibrary(hLib)
    If lRet = S_OK Then
        Set PicFromFaceID = iPic
    End If
    Exit Function
    
errHandler:
    Call FreeLibrary(hLib)
    EmptyClipboard
    CloseClipboard
    
End Function





'________________________________________ VBE Exceptions Handling Routines ________________________________________

#If VBA7 Then
    Private Function CatchErrorFunc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#Else
    Private Function CatchErrorFunc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If

    Dim sBuffer As String * 256, lRet As Long
    
    If nCode = HCBT_CREATEWND Then
        lRet = GetClassName(wParam, sBuffer, 256)
        If Left(sBuffer, lRet) = "#32770" Then
            SetProp Application.hwnd, "ErrWindow", wParam
            SetTimer Application.hwnd, 0, 0, AddressOf GetWText
        End If
    End If
    
    Call CallNextHookEx(GetProp(Application.hwnd, "hCBT"), nCode, wParam, lParam)
 
End Function


Private Sub GetWText()

    Dim sBuffer As String * 256, lRet As Long
    
    KillTimer Application.hwnd, 0
    lRet = GetWindowText(GetProp(Application.hwnd, "ErrWindow"), sBuffer, 256)
    If Left(sBuffer, lRet) = "Microsoft Visual Basic" Then
        If bDropShadow Then
            If GetClassLong(GetProp(Application.hwnd, "hForm"), GCL_STYLE) Or CS_DROPSHADOW Then
                SetClassLong GetProp(Application.hwnd, "hForm"), GCL_STYLE, _
                GetClassLong(GetProp(Application.hwnd, "hForm"), GCL_STYLE) And Not CS_DROPSHADOW
            End If
        End If
        UnhookWindowsHookEx GetProp(Application.hwnd, "hCBT")
        Call RemoveProp(Application.hwnd, "hCBT")
        Call RemoveProp(Application.hwnd, "ErrWindow")
        Call SubClassForm(False)
    End If

End Sub

CODE USAGE:

2- Code in the UserForm Module ( As per the example in the above download workbook):

VBA Code:

Option Explicit

Dim R As Byte, G As Byte, B As Byte



Private Sub UserForm_Initialize()

    Dim i As Integer
    
    CB_R.Style = fmStyleDropDownList
    CB_G.Style = fmStyleDropDownList
    CB_B.Style = fmStyleDropDownList
    
    For i = 0 To 255
        CB_R.AddItem i
        CB_G.AddItem i
        CB_B.AddItem i
    Next i

'    Change Icon File path as required.
    Call FormatFormCaption( _
        Form:=Me, _
        TitleBarColor:=vbCyan, _
        GradientFill:=True, _
        DropShadow:=True, _
        FontName:="MV Boli", _
        FontColor:=vbRed, _
        FontSize:=8, _
        FontBold:=True, _
        FontItalic:=True, _
        FontUnderline:=False, _
        IconFile:="C:\Users\Info-Hp\Downloads\5-2-canada-flag-png-image_64x64.ico" _
    )
    

    Call ConvertLongToRGB(vbCyan, R, G, B)
    CB_R.Value = R: CB_G.Value = G: CB_B.Value = B

End Sub



Private Sub BtnClose_Click()
    Unload Me
End Sub

Private Sub CB_R_Change()
    R = CB_R.Value
    lTitleBarColor = RGB(R, G, B)
    Call UpdateForm
End Sub
Private Sub CB_G_Change()
    G = CB_G.Value
    lTitleBarColor = RGB(R, G, B)
    Call UpdateForm
End Sub
Private Sub CB_B_Change()
    B = CB_B.Value
    lTitleBarColor = RGB(R, G, B)
    Call UpdateForm
End Sub


Private Sub SpinButton1_SpinDown()
    lCaptionTitleOffset = lCaptionTitleOffset - 1
    Call UpdateForm
End Sub
Private Sub SpinButton1_SpinUp()
    lCaptionTitleOffset = lCaptionTitleOffset + 1
    Call UpdateForm
End Sub


Private Sub BtnMsgBoxText_Click()
    MsgBox "Test"
End Sub

Private Sub BtnLoadIcon_Click()
    Dim IconFile As Variant
    
    IconFile = Application.GetOpenFilename(FileFilter:="Icon Files (*.ICO), *.ICO", _
    Title:="Title")
    If IconFile <> False Then
        sIconFilePath = IconFile
        Call UpdateForm
    End If
End Sub

Private Sub BtnErrTest_Click()
    Err.Raise VBA.vbObjectError, , "error occured no crash"
End Sub

Private Sub ToglDradient_Click()
    bGradientFill = Not bGradientFill
    Call UpdateForm
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

DataBlake · Jan 30, 2020

Jaafar Tribak said:
... and in Windows10 64-Bit Office 2016 64-Bit.....
The thing with API coding is that it often needs readjusting for different Windows\office versions.

yeah it worked for me in windows 10 64 bit excel 2016

Jon Peltier · Jan 30, 2020

So I tried on another computer with Windows 10 Enterprise and again, the latest Excel 365 Insiders build.

Nothing happened to the UserForm, but when I clicked the Close button on the form, Excel crashed.

Jon Peltier · Jan 30, 2020

I cleaned the code, saved as xlsm, and tried again, and crashed twice more.

These APIs sometimes are great, and sometimes will spoil your whole day.

Jaafar Tribak · Jan 30, 2020

Jon Peltier said:
I cleaned the code, saved as xlsm, and tried again, and crashed twice more.

These APIs sometimes are great, and sometimes will spoil your whole day.

Sorry for the inconvinience ... I agree and debugging api code can be a nightmare .
I have never used excel 365 and apparently (based on users reports) , this is the excel edition where API code seems to cause most problems.

Regards.

Jon Peltier · Jan 30, 2020

I use a small number of APIs in my regular code, and they are fine in 365.

I think just code that changed the color of the title bar and border would be all I needed. I don't really care about font or icons.

Jaafar Tribak · Nov 15, 2021

Take a look here for a new approach without needing to subclass the userform (more stable)

Drawing on UserForm Title-Bar and adding some cool formatting

Jaafar Tribak

Well-known Member

DataBlake

Well-known Member

Excel Facts

Jon Peltier

MrExcel MVP

Jon Peltier

MrExcel MVP

Jaafar Tribak

Well-known Member

Jon Peltier

MrExcel MVP

Jaafar Tribak

Well-known Member

Similar threads

Forum statistics

Share this page

Drawing on UserForm Title-Bar and adding some cool formatting

Jaafar Tribak

Well-known Member

DataBlake

Well-known Member

Excel Facts

Jon Peltier

MrExcel MVP

Jon Peltier

MrExcel MVP

Jaafar Tribak

Well-known Member

Jon Peltier

MrExcel MVP

Jaafar Tribak

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock