Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,797
- Office Version
- 2016
- Platform
- Windows
Hi all,
I already wrote some code before for customizing the titlebar of userforms HERE and HERE.
Unfortunately, both codes relied on subclassing the userform which poses problems of its own. Problems such as risks of crashing excel during IDE testings or during unhandled errors... Also, subclassing works only with vbModal forms. Attempting to subclass a Modeless userform is a recipe for disaster.
Here, I have taken a different approach which doesn't use subclassing\hooking at all. The code doesn't override or interfere with the current Windows theme either and works with Modal as well as with Modeless userforms.
The code allows for the following:
A: Change the caption color (Gradient Fill Optional).
B: Change the Font and its attributes.
C; Adds an X Button and a context menu for closing the userform + (Alt+F4).
D: Adds a shadow to the userform.
E: Adds an Optional Icon.
F: Allows for disabling the caption when the userform is Deactivated (vbModeless only).
G: Choice between left aligned caption text or Centered text.
H: Optional fine Frame drawn around the userform.
Workbook Example
1- CTitleBar (Class Code)
2- Code Usage Example in UserForm:
Code tested on excel 2016 x64bit, Win 10 x64bit but hopefully should work on other platforms.
I already wrote some code before for customizing the titlebar of userforms HERE and HERE.
Unfortunately, both codes relied on subclassing the userform which poses problems of its own. Problems such as risks of crashing excel during IDE testings or during unhandled errors... Also, subclassing works only with vbModal forms. Attempting to subclass a Modeless userform is a recipe for disaster.
Here, I have taken a different approach which doesn't use subclassing\hooking at all. The code doesn't override or interfere with the current Windows theme either and works with Modal as well as with Modeless userforms.
The code allows for the following:
A: Change the caption color (Gradient Fill Optional).
B: Change the Font and its attributes.
C; Adds an X Button and a context menu for closing the userform + (Alt+F4).
D: Adds a shadow to the userform.
E: Adds an Optional Icon.
F: Allows for disabling the caption when the userform is Deactivated (vbModeless only).
G: Choice between left aligned caption text or Centered text.
H: Optional fine Frame drawn around the userform.
Workbook Example
1- CTitleBar (Class Code)
VBA Code:
Option Explicit
Private WithEvents oFrame As MSForms.Frame
Private WithEvents objForm As MSForms.UserForm
Private Type CaptionData
tSize As Long
CaptionColor As Variant
FontName As String * 256
FontSize As Long
FontColor As Long
FontBold As Boolean
FontItalic As Boolean
DrawFrame As Boolean
CenterText As Boolean
GradientColor As Boolean
'//Applies to vbModeless UserForms only. //
DisableWhenInActive As Boolean '//
'// '// //
IconFile As String * 256
End Type
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 NCL_METRICS
CaptionHeight As Single
FrameWidth As Single
FrameHeight As Single
End Type
Private Type uPicDesc
Size As Long
Type As Long
#If Win64 Then
hPic As LongLong
hPal As LongLong
#Else
hPic As Long
hPal As Long
#End If
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
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
Private Type MYFONT
FontName As String
FontSize As Long
FontBold As Boolean
FontItalic As Boolean
End Type
'// GDIPlus TYPES
Private Type COLORMATRIX
M(0 To 4, 0 To 4) As Single
End Type
Private Type GDIPlusStartupInput
GdiPlusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
'//
#If VBA7 Then
#If Win64 Then
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 GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
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
Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) As Long
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
#Else
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
#End If
Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) 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 DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function ReleaseCapture Lib "user32" () As Long
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex 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 GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nBkMode As Long) As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As uPicDesc, RefIID As Any, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) 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 DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As LongPtr, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat 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 CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) 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 SetTextColor Lib "gdi32" (ByVal hDC As LongPtr, ByVal crColor As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As LongPtr, 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 DestroyIcon Lib "user32" (ByVal hIcon As LongPtr) As Long
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 TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As LongPtr, Col As Long) As Long
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 CreatePopupMenu Lib "user32" () As LongPtr
Private Declare PtrSafe Function DestroyMenu Lib "user32" (ByVal hMenu As LongPtr) 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 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 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 CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare PtrSafe Function SelectClipRgn Lib "gdi32" (ByVal hDC As LongPtr, ByVal hRgn As LongPtr) 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 CombineRgn Lib "gdi32" (ByVal hDestRgn As LongPtr, ByVal hSrcRgn1 As LongPtr, ByVal hSrcRgn2 As LongPtr, ByVal nCombineMode As Long) As Long
Private Declare PtrSafe Function SetWindowRgn Lib "user32" (ByVal hwnd As LongPtr, ByVal hRgn As LongPtr, ByVal bRedraw As Long) 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 GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function MoveToEx Lib "gdi32" (ByVal hDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal lpPoint As Long) As Long
Private Declare PtrSafe Function LineTo Lib "gdi32" (ByVal hDC As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function IsWindowEnabled Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function ShowWindow Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function SetActiveWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
'GDIPlus declares
Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GDIPlusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, BITMAP As LongPtr) As Long
Private Declare PtrSafe Function GdipGetImageThumbnail Lib "gdiplus" (ByVal Image As LongPtr, ByVal thumbWidth As Long, ByVal thumbHeight As Long, thumbImage As LongPtr, ByVal Callback As LongPtr, ByVal callbackData As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateFromHDC Lib "gdiplus" (ByVal hDC As LongPtr, hGraphics As LongPtr) As Long
Private Declare PtrSafe Function GdipSetImageAttributesColorMatrix Lib "gdiplus" (ByVal imageattr As LongPtr, ByVal ColorAdjust As Long, ByVal EnableFlag As Boolean, ByRef MatrixColor As COLORMATRIX, ByRef MatrixGray As COLORMATRIX, ByVal flags As Long) As Long
Private Declare PtrSafe Function GdipCreateImageAttributes Lib "gdiplus" (ByRef imageattr As LongPtr) As Long
Private Declare PtrSafe Function GdipSetSmoothingMode Lib "gdiplus" (ByVal graphics As LongPtr, ByVal SmoothingMd As Long) As Long
Private Declare PtrSafe Function GdipGetImageHeight Lib "GdiPlus.dll" (ByVal mImage As LongPtr, ByRef mHeight As Long) As Long
Private Declare PtrSafe Function GdipGetImageWidth Lib "GdiPlus.dll" (ByVal mImage As LongPtr, ByRef mWidth As Long) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal Image As LongPtr) As LongPtr
Private Declare PtrSafe Function GdipDrawImageRectRectI Lib "gdiplus" (ByVal hGraphics As LongPtr, ByVal hImage As LongPtr, ByVal DstX As Long, ByVal DstY As Long, ByVal DstWidth As Long, ByVal DstHeight As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal SrcWidth As Long, ByVal SrcHeight As Long, ByVal srcUnit As Long, Optional ByVal imageAttributes As LongPtr = 0, Optional ByVal Callback As Long = 0, Optional ByVal callbackData As Long = 0) As Long
Private Declare PtrSafe Function GdipDeleteGraphics Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImageAttributes Lib "gdiplus" (ByVal imageattr As LongPtr) As Long
Private hwnd As LongPtr, hIcon As LongPtr, hShadow As LongPtr
#Else
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function 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 PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
Private Declare Function 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 DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex 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 GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As uPicDesc, RefIID As Any, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat 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 CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) 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 DestroyIcon Lib "user32" (ByVal hIcon 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 TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col 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 CreatePopupMenu Lib "user32" () As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu 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 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 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 CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn 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 CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw 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 GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal lpPoint As Long) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function IsWindowEnabled Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ShowWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetActiveWindow Lib "user32" (ByVal hwnd As Long) As Long
'GDIPlus declares
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GDIPlusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long
Private Declare Function GdipGetImageThumbnail Lib "gdiplus" (ByVal Image As Long, ByVal thumbWidth As Long, ByVal thumbHeight As Long, thumbImage As Long, ByVal Callback As Long, ByVal callbackData As Long) As Long
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hDC As Long, hGraphics As Long) As Long
Private Declare Function GdipSetImageAttributesColorMatrix Lib "gdiplus" (ByVal imageattr As Long, ByVal ColorAdjust As Long, ByVal EnableFlag As Boolean, ByRef MatrixColor As COLORMATRIX, ByRef MatrixGray As COLORMATRIX, ByVal flags As Long) As Long
Private Declare Function GdipCreateImageAttributes Lib "gdiplus" (ByRef imageattr As Long) As Long
Private Declare Function GdipSetSmoothingMode Lib "gdiplus" (ByVal graphics As Long, ByVal SmoothingMd As Long) As Long
Private Declare Function GdipGetImageHeight Lib "GdiPlus.dll" (ByVal mImage As Long, ByRef mHeight As Long) As Long
Private Declare Function GdipGetImageWidth Lib "GdiPlus.dll" (ByVal mImage As Long, ByRef mWidth As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
Private Declare Function GdipDrawImageRectRectI Lib "gdiplus" (ByVal hGraphics As Long, ByVal hImage As Long, ByVal DstX As Long, ByVal DstY As Long, ByVal DstWidth As Long, ByVal DstHeight As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal SrcWidth As Long, ByVal SrcHeight As Long, ByVal srcUnit As Long, Optional ByVal imageAttributes As Long = 0, Optional ByVal Callback As Long = 0, Optional ByVal callbackData As Long = 0) As Long
Private Declare Function GdipDeleteGraphics Lib "GdiPlus.dll" (ByVal mGraphics As Long) As Long
Private Declare Function GdipDisposeImageAttributes Lib "gdiplus" (ByVal imageattr As Long) As Long
Private hwnd As Long, hIcon As Long, hShadow As Long
#End If
Private BMPsCol As Collection
Private FramePicsCollection As Collection
Private CaptionPicsCollection As Collection
Private tMt As NCL_METRICS
Private tFont As MYFONT
Private lBackColor As Long
Private sFontName As String
Private sIconFile As String
Private sFormCaption As String
Private lFontColor As Long
Private bGradientColor As Boolean
Private bCenterText As Boolean
Private bDisableWhenInActive As Boolean
Private bDrawFrame As Boolean
#If Win64 Then
Public Sub Attach(ByVal oForm As Object, ByVal pCD As LongLong)
#Else
Public Sub Attach(ByVal oForm As Object, ByVal pCD As Long)
#End If
Const LR_LOADFROMFILE = &H10
Const IMAGE_ICON = 1
Const DFCS_HOT = &H1000
Const DFCS_PUSHED = &H200
Const DFCS_INACTIVE = 256
Const COLOR_BTNHIGHLIGHT = 20
Dim tCD As CaptionData
Set objForm = oForm
Call IUnknown_GetWindow(oForm, VarPtr(hwnd))
Call CopyMemory(ByVal tCD, ByVal pCD, LenB(tCD))
With tCD
sFontName = Left(.FontName, InStr(1, .FontName, vbNullChar) - 1)
tFont.FontName = IIf(Len(sFontName), sFontName, oForm.Font.Name)
tFont.FontItalic = .FontItalic
tFont.FontSize = IIf(.FontSize, .FontSize, oForm.Font.Size)
lFontColor = .FontColor
lBackColor = IIf(TypeName(.CaptionColor) = "Empty", GetSysColor(COLOR_BTNHIGHLIGHT), .CaptionColor)
bDrawFrame = .DrawFrame
bCenterText = .CenterText
bGradientColor = .GradientColor
bDisableWhenInActive = .DisableWhenInActive
sIconFile = Left(.IconFile, InStr(1, .IconFile, vbNullChar) - 1)
End With
sFormCaption = oForm.Caption
If Len(Dir(sIconFile)) Then
hIcon = LoadImage(0, sIconFile, IMAGE_ICON, 0, 0, LR_LOADFROMFILE)
End If
tMt = GetWinMetrics()
Call ChangeFormWinStyles(oForm)
Call ShiftFormControls(ByVal oForm)
Call AddCloseFrame(oForm)
Call DrawActiveCaption(oForm)
If bDisableWhenInActive Then
Call DrawInActiveCaption(oForm)
End If
Call DrawCloseBtn(oFrame, 0)
Call DrawCloseBtn(oFrame, DFCS_HOT)
Call DrawCloseBtn(oFrame, DFCS_PUSHED)
Call DrawCloseBtn(oFrame, DFCS_INACTIVE)
End Sub
Public Sub Enable(ByVal bEnable As Boolean)
If bEnable Then
If CaptionPicsCollection.Count Then
Set objForm.Picture = CaptionPicsCollection("ActiveCaptionPic")
End If
If FramePicsCollection.Count Then
Set oFrame.Picture = FramePicsCollection(1)
End If
Call CreateShadow
Else
If bDisableWhenInActive Then
If CaptionPicsCollection.Count > 1 Then
If IsWindowEnabled(Application.hwnd) Then
Set objForm.Picture = CaptionPicsCollection("InActiveCaptionPic")
End If
End If
End If
If FramePicsCollection.Count Then
Set oFrame.Picture = FramePicsCollection(4)
End If
Call DestroyWindow(hShadow)
End If
End Sub
Private Sub Class_Terminate()
Call CleanUp
End Sub
Private Sub CleanUp()
Dim i As Long
Call DestroyWindow(hShadow)
Call DestroyIcon(hIcon)
If Not BMPsCol Is Nothing Then
With BMPsCol
For i = .Count To 1 Step -1
Call DeleteObject(.Item(i))
.Remove i
Next i
End With
End If
Set BMPsCol = Nothing
Set FramePicsCollection = Nothing
Set CaptionPicsCollection = Nothing
End Sub
Private Sub DrawActiveCaption(ByVal oForm As Object)
Const SM_CXICON = 11
Const SM_CXBORDER = 5
Const SM_CXFRAME = 32
Const DT_SINGLELINE = &H20
Const DT_CALCRECT = &H400
Const PS_SOLID = 1
Const TRANSPARENT = 1
Const GRADIENT_FILL_RECT_H = &H0
#If Win64 Then
Dim hDC As LongLong, hBrush As LongLong, hPrevFont As LongLong, hOldBrush As LongLong
Dim hMemDC As LongLong, hMemBmp As LongLong, hOldBmp As LongLong, hPen As LongLong, hOldPen As LongLong
#Else
Dim hDC As Long, hBrush As Long, hPrevFont As Long, hOldBrush As Long
Dim hMemDC As Long, hMemBmp As Long, hOldBmp As Long, hPen As Long, hOldPen As Long
#End If
Dim tTitleBarRect As RECT, tClientRect As RECT, tTextRect As RECT, tTextPosRect As RECT
Dim vert(2) As TRIVERTEX, tPt As GRADIENT_RECT
Dim IFont As stdole.IFont
Dim lTextHeight As Long, lFrmColor As Long, lPenColor As Long
Dim R As Byte, G As Byte, B As Byte
On Error GoTo Xit
hDC = GetDC(hwnd)
Call GetClientRect(hwnd, tClientRect)
hMemDC = CreateCompatibleDC(0)
hMemBmp = CreateCompatibleBitmap(hDC, tClientRect.Right, tClientRect.Bottom)
hOldBmp = SelectObject(hMemDC, hMemBmp)
lFrmColor = oForm.BackColor
Call TranslateColor(oForm.BackColor, 0, lFrmColor)
hBrush = CreateSolidBrush(lFrmColor)
hOldBrush = SelectObject(hMemDC, hBrush)
Call FillRect(hMemDC, tClientRect, hBrush)
Call SelectObject(hMemDC, hOldBrush)
Call DeleteObject(hBrush)
If bDrawFrame Then
lPenColor = lBackColor
If lBackColor = vbWhite Then lPenColor = 0
hPen = CreatePen(PS_SOLID, 2, lPenColor)
hOldPen = SelectObject(hMemDC, hPen)
With tClientRect
Call MoveToEx(hMemDC, .Left, .Top, ByVal 0)
Call LineTo(hMemDC, .Right, .Top)
Call LineTo(hMemDC, .Right, .Bottom)
Call LineTo(hMemDC, .Left, .Bottom)
Call LineTo(hMemDC, .Left, .Top)
End With
Call DeleteObject(hPen)
End If
With tClientRect
Call SetRect(tTitleBarRect, 0, -tMt.FrameHeight, .Right, .Top + tMt.CaptionHeight + 1)
End With
Call ConvertLongToRGB(lBackColor, R, G, B)
With vert(0)
.X = 1
.Y = 1
.Red = TransfCol(R)
.Green = TransfCol(G)
.Blue = TransfCol(B)
.alpha = TransfCol(0)
End With
With vert(1)
.X = tTitleBarRect.Right - tTitleBarRect.Left - 1
.Y = tTitleBarRect.Bottom - tTitleBarRect.Top - 1
.Red = IIf(bGradientColor, 0, TransfCol(R))
.Green = IIf(bGradientColor, 0, TransfCol(G))
.Blue = IIf(bGradientColor, 0, TransfCol(B))
.alpha = TransfCol(0)
End With
tPt.UpperLeft = 0: tPt.LowerRight = 1
Call GradientFillRect(hMemDC, vert(0), 2, tPt, 1, GRADIENT_FILL_RECT_H)
Call DrawIcon(hMemDC, 2, 1, hIcon)
Set IFont = oForm.Font
With tFont
If Len(.FontName) Then
IFont.Name = .FontName
IFont.Size = .FontSize
IFont.Bold = .FontBold
IFont.Italic = .FontItalic
End If
End With
hPrevFont = SelectObject(hMemDC, IFont.hFont)
Call SetBkMode(hMemDC, TRANSPARENT)
Call SetTextColor(hMemDC, lFontColor)
lTextHeight = DrawText(hMemDC, sFormCaption, Len(sFormCaption), tTextRect, DT_CALCRECT)
With tClientRect
Call SetRect(tTitleBarRect, 0, 0, .Right, tMt.CaptionHeight + tMt.FrameHeight)
End With
With tTitleBarRect
If bCenterText Then
Call SetRect( _
tTextPosRect, ((.Right) - (tTextRect.Right)) / 2, _
((tMt.CaptionHeight + tMt.FrameWidth + tMt.FrameHeight) - tTextRect.Bottom) / 2, _
.Right, _
.Bottom)
Else
Call SetRect( _
tTextPosRect, _
IIf(hIcon, GetSystemMetrics(SM_CXICON) + _
GetSystemMetrics(SM_CXFRAME), _
GetSystemMetrics(SM_CXFRAME) + _
GetSystemMetrics(SM_CXBORDER)), _
((tMt.CaptionHeight + tMt.FrameWidth + tMt.FrameHeight) - tTextRect.Bottom) / 2, _
.Right, _
.Bottom)
End If
End With
Call DrawText(hMemDC, sFormCaption, Len(sFormCaption), tTextPosRect, DT_SINGLELINE)
If CaptionPicsCollection Is Nothing Then
Set CaptionPicsCollection = New Collection
End If
CaptionPicsCollection.Add BmpToStdPic(hMemBmp), "ActiveCaptionPic"
If BMPsCol Is Nothing Then
Set BMPsCol = New Collection
End If
BMPsCol.Add hMemBmp
Xit:
Call SelectObject(hMemDC, hOldBmp)
Call DeleteObject(hOldBmp)
Call SelectObject(hMemDC, hPrevFont)
Call DeleteObject(hPrevFont)
Call DeleteDC(hMemDC)
Call ReleaseDC(hwnd, hDC)
If Err.Number <> 0 Then Call DestroyWindow(hShadow)
End Sub
Private Sub DrawInActiveCaption(ByVal oForm As Object)
Const SM_CXICON = 11
Const SM_CXBORDER = 5
Const SM_CXFRAME = 32
Const COLOR_BTNFACE = 15
Const COLOR_BTNHIGHLIGHT = 20
Const COLOR_INACTIVECAPTION = 3
Const SRCCOPY = &HCC0020
Const DT_SINGLELINE = &H20
Const DT_CALCRECT = &H400
Const PS_SOLID = 1
Const TRANSPARENT = 1
Const RGN_DIFF = 4
#If Win64 Then
Dim hDC As LongLong, hBrush As LongLong, hPrevFont As LongLong, hOldBrush As LongLong
Dim hMemDC As LongLong, hMemBmp As LongLong, hOldBmp As LongLong, hPen As LongLong, hOldPen As LongLong
Dim hDisabledMemDc As LongLong, hDisabledMemBmp As LongLong, hDisabledOldMemBmp As LongLong
Dim hRgn1 As LongLong, hRgn2 As LongLong
#Else
Dim hDC As Long, hBrush As Long, hPrevFont As Long, hOldBrush As Long
Dim hMemDC As Long, hMemBmp As Long, hOldBmp As Long, hPen As Long, hOldPen As Long
Dim hDisabledMemDc As Long, hDisabledMemBmp As Long, hDisabledOldMemBmp As Long
Dim hRgn1 As Long, hRgn2 As Long
#End If
Dim tTitleBarRect As RECT, tClientRect As RECT, tTextRect As RECT, tTextPosRect As RECT
Dim IFont As stdole.IFont
Dim lTextHeight As Long, lRealColor As Long
On Error GoTo Xit
hDC = GetDC(hwnd)
Call GetClientRect(hwnd, tClientRect)
hMemDC = CreateCompatibleDC(0)
hMemBmp = CreateCompatibleBitmap(hDC, tClientRect.Right, tClientRect.Bottom)
hOldBmp = SelectObject(hMemDC, hMemBmp)
Call TranslateColor(oForm.BackColor, 0, lRealColor)
hBrush = CreateSolidBrush(lRealColor)
hOldBrush = SelectObject(hMemDC, hBrush)
Call FillRect(hMemDC, tClientRect, hBrush)
Call SelectObject(hMemDC, hOldBrush)
Call DeleteObject(hBrush)
With tTitleBarRect
.Left = tClientRect.Left
.Top = tClientRect.Top
.Right = tClientRect.Right
.Bottom = tClientRect.Top + tMt.CaptionHeight + tMt.FrameHeight
End With
Call TranslateColor(oForm.BackColor, 0, lRealColor)
If GetSysColor(COLOR_BTNFACE) = lRealColor Then
hBrush = CreateSolidBrush(GetSysColor(COLOR_BTNHIGHLIGHT))
Else
hBrush = CreateSolidBrush(GetSysColor(COLOR_BTNFACE))
End If
Call FillRect(hMemDC, tTitleBarRect, hBrush)
Call DeleteObject(hBrush)
Call DrawIcon(hMemDC, 2, 1, hIcon)
Set IFont = oForm.Font
With tFont
If Len(.FontName) Then
IFont.Name = .FontName
IFont.Size = .FontSize
IFont.Bold = .FontBold
IFont.Italic = .FontItalic
End If
End With
hPrevFont = SelectObject(hMemDC, IFont.hFont)
Call SetBkMode(hMemDC, TRANSPARENT)
Call SetTextColor(hMemDC, &HAB40&)
lTextHeight = DrawText(hMemDC, sFormCaption, Len(sFormCaption), tTextRect, DT_CALCRECT)
With tClientRect
Call SetRect(tTitleBarRect, 0, 0, .Right, tMt.CaptionHeight + tMt.FrameHeight)
End With
With tTitleBarRect
If bCenterText Then
Call SetRect( _
tTextPosRect, ((.Right) - (tTextRect.Right)) / 2, _
((tMt.CaptionHeight + tMt.FrameWidth + tMt.FrameHeight) - tTextRect.Bottom) / 2, _
.Right, _
.Bottom)
Else
Call SetRect( _
tTextPosRect, _
IIf(hIcon, GetSystemMetrics(SM_CXICON) + _
GetSystemMetrics(SM_CXFRAME), _
GetSystemMetrics(SM_CXFRAME) + _
GetSystemMetrics(SM_CXBORDER)), _
((tMt.CaptionHeight + tMt.FrameWidth + tMt.FrameHeight) - tTextRect.Bottom) / 2, _
.Right, _
.Bottom)
End If
End With
Call DrawText(hMemDC, sFormCaption, Len(sFormCaption), tTextPosRect, DT_SINGLELINE)
hDisabledMemDc = CreateCompatibleDC(0)
hDisabledMemBmp = CreateCompatibleBitmap(hDC, tClientRect.Right, tClientRect.Bottom)
hDisabledOldMemBmp = SelectObject(hDisabledMemDc, hDisabledMemBmp)
With tClientRect
Call BitBlt(hDisabledMemDc, 0, 0, .Right, .Bottom, hMemDC, 0, 0, SRCCOPY)
hRgn1 = CreateRectRgn(0, 0, .Right, .Bottom)
hRgn2 = CreateRectRgn(0, tMt.CaptionHeight + tMt.FrameHeight, .Right - 1, .Bottom - 1)
Call CombineRgn(hRgn2, hRgn1, hRgn2, RGN_DIFF)
Call SelectClipRgn(hDisabledMemDc, hRgn2)
Call DrawDisabledBitmap(hDisabledMemDc, hDisabledMemBmp, 0, 0, .Right, .Bottom)
Call SelectClipRgn(hDisabledMemDc, 0)
Call TranslateColor(GetSysColor(COLOR_INACTIVECAPTION), 0, lRealColor)
hPen = CreatePen(PS_SOLID, 2, lRealColor)
hOldPen = SelectObject(hDisabledMemDc, hPen)
With tClientRect
Call MoveToEx(hDisabledMemDc, .Left, .Top, ByVal 0)
Call LineTo(hDisabledMemDc, .Right, .Top)
Call LineTo(hDisabledMemDc, .Right, .Bottom)
Call LineTo(hDisabledMemDc, .Left, .Bottom)
Call LineTo(hDisabledMemDc, .Left, .Top)
End With
Call DeleteObject(hPen)
End With
If CaptionPicsCollection Is Nothing Then
Set CaptionPicsCollection = New Collection
End If
CaptionPicsCollection.Add BmpToStdPic(hDisabledMemBmp), "InActiveCaptionPic"
If BMPsCol Is Nothing Then
Set BMPsCol = New Collection
End If
BMPsCol.Add hDisabledMemBmp
Xit:
Call SelectObject(hMemDC, hOldBmp)
Call DeleteObject(hOldBmp)
Call SelectObject(hMemDC, hPrevFont)
Call DeleteObject(hPrevFont)
Call DeleteDC(hMemDC)
Call SelectObject(hDisabledMemDc, hDisabledOldMemBmp)
Call DeleteObject(hDisabledOldMemBmp)
Call DeleteDC(hDisabledMemDc)
Call ReleaseDC(hwnd, hDC)
If Err.Number <> 0 Then Call DestroyWindow(hShadow)
End Sub
#If Win64 Then
Private Function DrawDisabledBitmap(ByVal hDC As LongLong, ByVal hBitmap As LongLong, ByVal Left As Long, ByVal Top As Long, Optional ByVal Width As Long = -1, Optional ByVal Height As Long = -1) As Boolean
Dim hImage As LongLong, hGraphics As LongLong, hAttributes As LongLong
#Else
Private Function DrawDisabledBitmap(ByVal hDC As Long, ByVal hBitmap As Long, ByVal Left As Long, ByVal Top As Long, Optional ByVal Width As Long = -1, Optional ByVal Height As Long = -1) As Boolean
Dim hImage As Long, hGraphics As Long, hAttributes As Long
#End If
'Credit for this function goes to LeandroA at VBForums-- Thanks.
'https://www.vbforums.com/showthread.php?894142-Embossed-Disabled-Bitmap&p=5543513&viewfull=1#post5543513
Const SmoothingModeAntiAlias As Long = 4
Dim GdipStartupInput As GDIPlusStartupInput
Dim GdipToken As Long
Dim tMatrixColor As COLORMATRIX
Dim tMatrixGray As COLORMATRIX
Dim RealWidth As Long, RealHeight As Long
With tMatrixColor
.M(0, 0) = 0.299
.M(1, 0) = 0.299
.M(2, 0) = 0.299
.M(0, 1) = 0.587
.M(1, 1) = 0.587
.M(2, 1) = 0.587
.M(0, 2) = 0.114
.M(1, 2) = 0.114
.M(2, 2) = 0.114
.M(3, 3) = 1
.M(4, 4) = 1
End With
GdipStartupInput.GdiPlusVersion = 1&
If GdiplusStartup(GdipToken, GdipStartupInput, ByVal 0) = 0& Then
If GdipCreateFromHDC(hDC, hGraphics) = 0& Then
Call GdipSetSmoothingMode(hGraphics, SmoothingModeAntiAlias)
If GdipCreateBitmapFromHBITMAP(hBitmap, 0&, hImage) = 0& Then
Call GdipGetImageWidth(hImage, RealWidth)
Call GdipGetImageHeight(hImage, RealHeight)
If Width = -1 Then Width = RealWidth
If Height = -1 Then Height = RealHeight
Call GdipCreateImageAttributes(hAttributes)
Call GdipSetImageAttributesColorMatrix(hAttributes, &H0, True, tMatrixColor, tMatrixGray, &H0)
DrawDisabledBitmap = GdipDrawImageRectRectI(hGraphics, hImage, Left, Top, Width, Height, 0, 0, RealWidth, RealHeight, &H2, hAttributes) = 0&
Call GdipDisposeImage(hImage)
Call GdipDisposeImageAttributes(hAttributes)
End If
Call GdipDeleteGraphics(hGraphics)
End If
Call GdiplusShutdown(GdipToken)
End If
End Function
Private Sub ChangeFormWinStyles(ByVal oForm As Object)
Const GWL_STYLE = (-16)
Const GWL_EXSTYLE = (-20)
Const GCL_STYLE = -26
Const WS_BORDER = &H800000
Const WS_THICKFRAME = &H40000
Const WS_CAPTION = &HC00000
Const WS_DLGFRAME = &H400000
Const WS_EX_DLGMODALFRAME = &H1&
Const WS_EX_WINDOWEDGE = &H100&
Const WS_EX_STATICEDGE = &H20000
Call SetWindowLong(hwnd, GWL_STYLE, _
GetWindowLong(hwnd, GWL_STYLE) And Not (WS_BORDER Or WS_THICKFRAME _
Or WS_CAPTION Or WS_DLGFRAME))
Call SetWindowLong(hwnd, GWL_EXSTYLE, _
GetWindowLong(hwnd, GWL_EXSTYLE) And Not (WS_EX_DLGMODALFRAME Or _
WS_EX_WINDOWEDGE Or WS_EX_STATICEDGE))
Call DrawMenuBar(hwnd)
End Sub
Private Function DrawCloseBtn(ByVal oFrame As Frame, ByVal FrameState As Long) As StdPicture
Const DFCS_ADJUSTRECT = &H2000
Const DFC_CAPTION = 1
Const DFCS_CAPTIONCLOSE = &H0
#If Win64 Then
Dim hFrame As LongLong, hDC As LongLong, hMemDC As LongLong
Dim hMemBmp As LongLong, hOldBmp As LongLong
#Else
Dim hFrame As Long, hDC As Long, hMemDC As Long
Dim hMemBmp As Long, hOldBmp As Long
#End If
Dim tClientRect As RECT
Call IUnknown_GetWindow(oFrame, VarPtr(hFrame))
Call GetClientRect(hFrame, tClientRect)
hDC = GetDC(0)
hMemDC = CreateCompatibleDC(0)
hMemBmp = CreateCompatibleBitmap(hDC, tClientRect.Right, tClientRect.Bottom)
hOldBmp = SelectObject(hMemDC, hMemBmp)
If hMemBmp Then
Call DrawFrameControl(hMemDC, tClientRect, DFC_CAPTION, DFCS_CAPTIONCLOSE + DFCS_ADJUSTRECT + FrameState)
Set oFrame.Picture = BmpToStdPic(hMemBmp)
If BMPsCol Is Nothing Then
Set BMPsCol = New Collection
End If
BMPsCol.Add hMemBmp
If FramePicsCollection Is Nothing Then
Set FramePicsCollection = New Collection
End If
FramePicsCollection.Add oFrame.Picture
End If
Call ReleaseDC(0, hDC)
Call SelectObject(hMemDC, hOldBmp)
Call DeleteObject(hOldBmp)
Call DeleteDC(hMemDC)
End Function
Private Function GetWinMetrics() As NCL_METRICS
Const SM_CYCAPTION = 4
Const SM_CXBORDER = 5
Const SM_CYBORDER = 6
Const SM_CXEDGE = 45
Const SM_CXFIXEDFRAME = 7
Const SM_CYDLGFRAME = 8
Const SM_CYEDGE = 46
Const SM_CYFIXEDFRAME = 8
With tMt
.CaptionHeight = GetSystemMetrics(SM_CYCAPTION) + 1
.FrameHeight = GetSystemMetrics(SM_CYEDGE) + _
GetSystemMetrics(SM_CYFIXEDFRAME) + _
GetSystemMetrics(SM_CYBORDER) + _
GetSystemMetrics(SM_CYDLGFRAME)
.FrameWidth = GetSystemMetrics(SM_CXEDGE) + _
GetSystemMetrics(SM_CXFIXEDFRAME) + _
GetSystemMetrics(SM_CXBORDER)
End With
GetWinMetrics = tMt
End Function
Private Sub AddCloseFrame(ByVal oForm As Object)
Const SM_CXSMICON = 49
Const SM_CXBORDER = 5
Const SM_CXDLGFRAME = 7
Const SM_CYDLGFRAME = 8
Const SM_CYSMICON = 50
Const SM_CYCAPTION = 4
Dim lFrmColor As Long
Set oFrame = oForm.Controls.Add("Forms.Frame.1", "CloseFrame")
lFrmColor = oForm.BackColor
Call TranslateColor(oForm.BackColor, 0, lFrmColor)
With oFrame
.Left = oForm.InsideWidth - _
GetSystemMetrics(SM_CXSMICON) - _
GetSystemMetrics(SM_CXDLGFRAME) - _
GetSystemMetrics(SM_CXBORDER)
.Top = ((GetSystemMetrics(SM_CYCAPTION) + _
GetSystemMetrics(SM_CYDLGFRAME) - _
GetSystemMetrics(SM_CYSMICON)) / 2) - 1
.Width = GetSystemMetrics(SM_CXSMICON)
.Height = GetSystemMetrics(SM_CYSMICON)
.BackColor = lBackColor
.BorderStyle = fmBorderStyleSingle
.BorderColor = lFrmColor
.TabStop = False
.ZOrder 0
End With
End Sub
Private Sub ShiftFormControls(ByVal oForm As Object)
Const SM_CXDLGFRAME = 7
Const SM_CXBORDER = 5
Const SM_CXFIXEDFRAME = 7
Const SM_CXEDGE = 45
Dim Ctrl As Control
For Each Ctrl In oForm.Controls
If Ctrl.Parent Is oForm Then
Ctrl.Top = Ctrl.Top + PXtoPT(tMt.CaptionHeight + tMt.FrameHeight, True)
Ctrl.Left = Ctrl.Left + 1
End If
Next
oForm.Width = oForm.Width - _
PXtoPT(1 * GetSystemMetrics(SM_CXFIXEDFRAME) + _
1 * GetSystemMetrics(SM_CXBORDER) + _
0 * GetSystemMetrics(SM_CXEDGE), False)
oForm.Height = oForm.Height + 2
End Sub
Private Sub CreateShadow()
Const GWL_HWNDPARENT = (-8)
Const WS_POPUP = &H80000000
Const WS_VISIBLE = &H10000000
Const WS_DISABLED = &H8000000
Const SWP_NOSIZE = &H1
Const SWP_NOACTIVATE = &H10
Const SWP_DEFERERASE = &H2000
Const SWP_NOREDRAW = &H8
Const SWP_SHOWWINDOW = &H40
Const WS_EX_NOACTIVATE = &H8000000
Const WS_EX_TOOLWINDOW = &H80
Const COLOR_BTNSHADOW = 16
Const RGN_DIFF = 4
#If Win64 Then
Dim hRgn1 As LongLong, hRgn2 As LongLong, hDC As LongLong, hBrush As LongLong
#Else
Dim hRgn1 As Long, hRgn2 As Long, hDC As Long, hBrush As Long
#End If
Dim tFormRect As RECT, tRgnRect As RECT
Dim lOffset As Long
Call GetWindowRect(hwnd, tFormRect)
lOffset = 2
With tFormRect
If IsWindow(hShadow) = 0 Then
hShadow = CreateWindowEx(0 Or WS_EX_TOOLWINDOW Or WS_EX_NOACTIVATE, "BUTTON", vbNullString, _
WS_POPUP Or WS_DISABLED, 0, 0, .Right - .Left - (lOffset * 2), _
.Bottom - .Top - (lOffset * 2), 0, 0, GetModuleHandle(vbNullString), 0)
Call SetWindowLong(hShadow, GWL_HWNDPARENT, hwnd)
End If
Call SetRect(tRgnRect, 0, 0, .Right - .Left, .Bottom - .Top)
hBrush = CreateSolidBrush(&H595959)
hRgn1 = CreateRectRgn(0, 0, tRgnRect.Right, tRgnRect.Bottom)
hRgn2 = CreateRectRgn(0, 0, tRgnRect.Right - (lOffset * 3), tRgnRect.Bottom - (lOffset * 3))
Call CombineRgn(hRgn2, hRgn1, hRgn2, RGN_DIFF)
hDC = GetDC(hShadow)
Call SelectClipRgn(hDC, hRgn2)
Call SetWindowRgn(hShadow, hRgn2, True)
End With
With tFormRect
Call SetWindowPos(hShadow, hwnd, .Left + (lOffset * 3), .Top + (lOffset * 3), 0, 0, _
SWP_NOACTIVATE Or SWP_DEFERERASE Or SWP_NOSIZE Or SWP_SHOWWINDOW)
Call FillRect(hDC, tRgnRect, hBrush)
End With
Call DeleteObject(hBrush)
Call DeleteObject(hRgn1)
Call DeleteObject(hRgn2)
Call ReleaseDC(hShadow, hDC)
End Sub
Private Sub oFrame_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
Set oFrame.Picture = FramePicsCollection(3)
End If
End Sub
Private Sub oFrame_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If GetAsyncKeyState(VBA.vbKeyLButton) Then
Set oFrame.Picture = FramePicsCollection(3)
Else
Set oFrame.Picture = FramePicsCollection(2)
End If
End Sub
Private Sub oFrame_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Const SW_HIDE = 0
#If Win64 Then
Dim hFrame As LongLong, Ptr As LongLong
#Else
Dim hFrame As Long
#End If
Dim tCurPos As POINTAPI
If Button = 1 Then
Call IUnknown_GetWindow(oFrame, VarPtr(hFrame))
Call GetCursorPos(tCurPos)
#If Win64 Then
Call CopyMemory(Ptr, tCurPos, LenB(tCurPos))
If WindowFromPoint(Ptr) = hFrame Then
#Else
If WindowFromPoint(tCurPos.X, tCurPos.Y) = hFrame Then
#End If
Call ShowWindow(hShadow, SW_HIDE)
Call SetActiveWindow(hwnd)
Unload objForm
End If
End If
End Sub
Private Sub objForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Const WM_NCLBUTTONDOWN = &HA1
Const HTCAPTION = 2
Const SWP_NOSIZE = &H1
Const SWP_NOACTIVATE = &H10
Const SWP_DEFERERASE = &H2000
Const SWP_NOREDRAW = &H8
Const SWP_SHOWWINDOW = &H40
Const SW_HIDE = 0
Dim tFormRect As RECT, lOffset As Long
lOffset = 2
If IsMouseOverTitleBar(objForm) Then
If GetAsyncKeyState(VBA.vbKeyLButton) Then
If IsWindowVisible(hShadow) Then
If GetAsyncKeyState(VBA.vbKeyLButton) Then
Call ShowWindow(hShadow, SW_HIDE)
End If
End If
Else
If IsWindowVisible(hShadow) = 0 Then
Call GetWindowRect(hwnd, tFormRect)
With tFormRect
Call SetWindowPos(hShadow, hwnd, .Left + (lOffset * 3), .Top + (lOffset * 3), 0, 0, _
SWP_NOACTIVATE Or SWP_DEFERERASE Or SWP_NOSIZE Or SWP_SHOWWINDOW)
End With
End If
End If
If Button = 1 Then
Call ReleaseCapture
Call PostMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
End If
End If
If GetActiveWindow = hwnd Then
If FramePicsCollection.Count Then
Set oFrame.Picture = FramePicsCollection(1)
End If
End If
End Sub
Private Sub objForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Const MF_BYPOSITION = &H400
Const MF_STRING = &H0&
Const TPM_RETURNCMD = &H100&
Const SW_HIDE = 0
#If Win64 Then
Dim hMenu As LongLong
#Else
Dim hMenu As Long
#End If
Dim oStdPic As StdPicture
Dim tCursorPos As POINTAPI
Dim lShowPopupMenu As Long
If Button = 2 Then
If IsMouseOverTitleBar(objForm) Then
Set oStdPic = FaceIDToBMP(840)
hMenu = CreatePopupMenu()
Call AppendMenu(hMenu, MF_STRING, 1, "&Close (Alt +F4)")
If Not oStdPic Is Nothing Then
Call SetMenuItemBitmaps(hMenu, 0, MF_BYPOSITION, oStdPic, oStdPic)
End If
Call GetCursorPos(tCursorPos)
lShowPopupMenu = TrackPopupMenuEx(hMenu, TPM_RETURNCMD, tCursorPos.X, tCursorPos.Y, hwnd, ByVal 0&)
Set oStdPic = Nothing
Call DestroyMenu(hMenu)
If lShowPopupMenu = 1 Then
Call ShowWindow(hShadow, SW_HIDE)
Call SetActiveWindow(hwnd)
Unload objForm
End If
End If
End If
End Sub
Private Function IsMouseOverTitleBar(ByVal oForm As Object) As Boolean
Dim tMt As NCL_METRICS, tTitleBarRect As RECT
Dim p1 As POINTAPI, p2 As POINTAPI, tCurPos As POINTAPI
Dim lRet As Long
tMt = GetWinMetrics
Call GetClientRect(hwnd, tTitleBarRect)
With tTitleBarRect
p1.X = .Left
p1.Y = .Top
p2.X = .Right
p2.Y = .Top + tMt.CaptionHeight + tMt.FrameHeight
Call ClientToScreen(hwnd, p1)
Call ClientToScreen(hwnd, p2)
.Left = p1.X
.Top = p1.Y
.Right = p2.X
.Bottom = p2.Y
End With
Call GetCursorPos(tCurPos)
#If Win64 Then
Dim lPtr As LongLong
Call CopyMemory(lPtr, tCurPos, LenB(tCurPos))
lRet = PtInRect(tTitleBarRect, lPtr)
#Else
lRet = PtInRect(tTitleBarRect, tCurPos.X, tCurPos.Y)
#End If
If lRet Then
IsMouseOverTitleBar = True
End If
End Function
Private Function FaceIDToBMP(ByVal FaceID As Long) As StdPicture
#If Win64 Then
Dim hBmpPtr As LongLong
#Else
Dim hBmpPtr As Long
#End If
Const IMAGE_BITMAP = 0
Const LR_COPYDELETEORG = &H8
Const PICTYPE_BITMAP = 1
Const CF_BITMAP = 2
Const S_OK = &H0&
Dim IID_IDispatch As GUID, uPicInfo As uPicDesc
Dim IPic As Object, lRet As Long
On Error GoTo errHandler
Application.CommandBars.FindControl(ID:=FaceID).CopyFace
Call OpenClipboard(0)
hBmpPtr = GetClipboardData(CF_BITMAP)
Call DeleteObject(hBmpPtr)
hBmpPtr = CopyImage(hBmpPtr, IMAGE_BITMAP, 0, 0, LR_COPYDELETEORG)
If hBmpPtr Then
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With uPicInfo
.Size = Len(uPicInfo)
.Type = PICTYPE_BITMAP
.hPic = hBmpPtr
.hPal = 0
End With
lRet = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
If lRet = S_OK Then
Set FaceIDToBMP = IPic
End If
End If
errHandler:
Call EmptyClipboard
Call CloseClipboard
End Function
#If Win64 Then
Private Function BmpToStdPic(ByVal Bmp As LongLong) As StdPicture
#Else
Private Function BmpToStdPic(ByVal Bmp As Long) As StdPicture
#End If
Const PICTYPE_BITMAP = 1
Const S_OK = 0
Dim IID_IDispatch As GUID, uPicInfo As uPicDesc, oStdPic As StdPicture, lRet As Long
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With uPicInfo
.Size = Len(uPicInfo)
.Type = PICTYPE_BITMAP
.hPic = Bmp
.hPal = 0
End With
lRet = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, oStdPic)
If lRet = S_OK Then Set BmpToStdPic = oStdPic
End Function
Private Function ScreenDPI(ByVal bVert As Boolean) As Long
Const LOGPIXELSX As Long = 88
Const LOGPIXELSY As Long = 90
Static lDPI(1), hDC
If lDPI(0) = 0 Then
hDC = GetDC(0)
lDPI(0) = GetDeviceCaps(hDC, LOGPIXELSX)
lDPI(1) = GetDeviceCaps(hDC, LOGPIXELSY)
hDC = ReleaseDC(0, hDC)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Private Function PXtoPT(ByVal Pixels As Long, ByVal bVert As Boolean) As Single
Const POINTSPERINCH As Long = 72
PXtoPT = Pixels / (ScreenDPI(bVert) / POINTSPERINCH)
End Function
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 Function2- Code Usage Example in UserForm:
VBA Code:
Option Explicit
Private Type TITLE_BAR
tSize As Long
CaptionColor As Variant
FontName As String * 256
FontSize As Long
FontColor As Long
FontBold As Boolean
FontItalic As Boolean
DrawFrame As Boolean
CenterText As Boolean
GradientColor As Boolean
DisableWhenInActive As Boolean
IconFile As String * 256
End Type
Private oTitleBar As CTitleBar
Private Sub UserForm_Initialize()
Dim uTitleBar As TITLE_BAR
With uTitleBar
.tSize = LenB(uTitleBar)
.CaptionColor = vbRed
.FontName = "Orbitron" & vbNullChar
.FontSize = 24
.FontColor = vbCyan
.FontBold = True
.DrawFrame = True
.CenterText = True
.DisableWhenInActive = True
.GradientColor = True
.IconFile = ThisWorkbook.Path & "\test.ico" & vbNullChar '<==change icon path as needed.
End With
Set oTitleBar = New CTitleBar
Call oTitleBar.Attach(Me, VarPtr(uTitleBar))
End Sub
Private Sub UserForm_Activate()
oTitleBar.Enable True
End Sub
Private Sub UserForm_Deactivate()
oTitleBar.Enable False
End SubCode tested on excel 2016 x64bit, Win 10 x64bit but hopefully should work on other platforms.
Last edited:
