Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
Private Type PAINTSTRUCT
hdc As Long
fErase As Long
rcPaint As RECT
fRestore As Long
fIncUpdate As Long
rgbReserved(32) As Byte
End Type
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As String * 1
lfUnderline As String * 1
lfStrikeOut As String * 1
lfCharSet As String * 1
lfOutPrecision As String * 1
lfClipPrecision As String * 1
lfQuality As String * 1
lfPitchAndFamily As String * 1
lfFaceName As String * 32
End Type
Private Declare Function CreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" _
(lpLogFont As LOGFONT) As Long
Private Declare Function GetWindowDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, _
ByVal hdc As Long) As Long
Private Declare Function TextOut Lib "gdi32" _
Alias "TextOutA" _
(ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal lpString As String, _
ByVal nCount As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nBkMode As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function SetWindowsHookEx Lib _
"user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, _
ByVal ncode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" _
() As Long
Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" _
(ByVal hdc As Long, _
ByVal crColor As Long) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" _
(lpLogBrush As LOGBRUSH) As Long
Private Declare Function FillRect Lib "user32.dll" _
(ByVal hdc As Long, _
ByRef lpRect As RECT, _
ByVal hBrush As Long) As Long
Private Declare Function SetRect Lib "user32" _
(lpRect As RECT, _
ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpRect As RECT) As Long
Private Declare Function BeginPaint Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpPaint As PAINTSTRUCT) As Long
Private Declare Function EndPaint Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpPaint As PAINTSTRUCT) As Long
Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare Function RedrawWindow Lib "user32" _
(ByVal hwnd As Long, _
lprcUpdate As Any, _
ByVal hrgnUpdate As Long, _
ByVal fuRedraw As Long) As Long
Private Declare Function InvalidateRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal lpRect As Long, _
ByVal bErase As Long) As Long
Private Declare Function SetCursorPos Lib "user32.dll" _
(ByVal x As Long, _
ByVal y As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" _
(ByRef lpPoint As POINTAPI) As Long
Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long
Private Const WH_CBT As Long = 5
Private Const HCBT_ACTIVATE As Long = 5
Private Const GWL_WNDPROC As Long = -4
Private Const WM_ACTIVATE As Long = &H6
Private Const WM_PAINT As Long = &HF&
Private Const WM_SHOWWINDOW As Long = &H18
Private Const WM_EXITSIZEMOVE As Long = &H232
Private Const WM_DESTROY As Long = &H2
Private Const RDW_INTERNALPAINT As Long = &H2
Private Const SM_CXSCREEN As Long = 0
Private Const SM_CYSCREEN As Long = 1
Private Const SM_CYCAPTION As Long = 4
Private tPoint As POINTAPI
Private tRect As RECT
Private lPrevWnd As Long
Private lhHook As Long
Private bHookEnabled As Boolean
Private oForm As Object
Private sCaptionText As String
Private lCaptionColour As Long
Private lFontSize As Long
Private lFontColour As Long
Private bBold As Boolean
Sub HookUserForm _
(ByVal Form, ByVal CaptionColour, _
ByVal FontColour, ByVal FontSize, ByVal Bold)
'install a cbt hook to monitor for
'the activation of a window.
If Not bHookEnabled Then
'store parms in mod level vars.
Set oForm = Form
sCaptionText = Form.Caption
lCaptionColour = CaptionColour
lFontColour = FontColour
lFontSize = FontSize
bBold = Bold
lhHook = SetWindowsHookEx _
(WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId)
bHookEnabled = True
'show userform.
Form.Show
Else
MsgBox "The hook is already set.", vbInformation
End If
End Sub
Private Sub TerminateHook()
'important to unhook when done!
UnhookWindowsHookEx lhHook
bHookEnabled = False
End Sub
Private Function HookProc _
(ByVal idHook As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
Dim sBuffer As String
Dim lRetVal As Long
'check if a window has been activated.
If idHook = HCBT_ACTIVATE Then
'if so,get it's class name.
sBuffer = Space(256)
lRetVal = GetClassName(wParam, sBuffer, 256)
'check if it is an xl userform window
'that is being activated.
If Left(sBuffer, lRetVal) = "ThunderDFrame" Or _
Left(sBuffer, lRetVal) = "ThunderXFrame" Then
'if so,subclass it .
lPrevWnd = SetWindowLong _
(wParam, GWL_WNDPROC, AddressOf CallBackProc)
'done. so remove CBT hook.
Call TerminateHook
End If
End If
'Call next hook.
HookProc = CallNextHookEx _
(lhHook, idHook, ByVal wParam, ByVal lParam)
End Function
Private Function CallBackProc _
(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lDc As Long
On Error Resume Next
'get current userform position.
GetWindowRect hwnd, tRect
Select Case Msg
Case WM_PAINT, WM_ACTIVATE
If Msg = WM_ACTIVATE Then
Call MoveCursor
End If
lDc = GetWindowDC(hwnd)
Call DrawTitleBar(hwnd, lCaptionColour)
SetBkMode lDc, 1
SetTextColor lDc, lFontColour
CreateFont lDc, Bold:=bBold
TextOut lDc, 6, GetSystemMetrics(SM_CYCAPTION) / 3, _
sCaptionText, Len(sCaptionText)
ReleaseDC hwnd, lDc
InvalidateRect hwnd, 0, 0
Case WM_EXITSIZEMOVE, WM_SHOWWINDOW
If Msg = WM_SHOWWINDOW Then
SetCursorPos tPoint.x, tPoint.y
End If
SendMessage hwnd, WM_PAINT, 0, 0
Call MoveCursor
Case WM_DESTROY
SetWindowLong hwnd, GWL_WNDPROC, lPrevWnd
End Select
'process other msgs.
CallBackProc = CallWindowProc _
(lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
End Function
Private Sub CreateFont(DC As Long, Optional Bold As Boolean)
Dim uFont As LOGFONT
Dim lNewFont As Long
With uFont
.lfFaceName = "Tahoma" & Chr$(0)
.lfHeight = lFontSize
.lfWidth = 8
.lfWeight = IIf(Bold, 900, 100)
End With
lNewFont = CreateFontIndirect(uFont)
DeleteObject (SelectObject(DC, lNewFont))
End Sub
Private Sub DrawTitleBar _
(lhwnd As Long, Color)
Dim tPS As PAINTSTRUCT
Dim tLB As LOGBRUSH
Dim tR As RECT
Dim lDc As Long
Dim l As Long
Dim hBrush As Long
BeginPaint lhwnd, tPS
lDc = GetWindowDC(lhwnd)
tLB.lbColor = Color
'Create a new brush
hBrush = CreateBrushIndirect(tLB)
With oForm
SetRect tR, 0, 0, GetSystemMetrics _
(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN)
End With
'Fill the form with our brush
' FillRect lDc, tR, hBrush
FillRect lDc, tR, hBrush
Call DeleteObject(hBrush)
RedrawWindow lhwnd, ByVal 0&, ByVal 0&, RDW_INTERNALPAINT
DeleteDC lDc
Call EndPaint(lhwnd, tPS)
End Sub
Private Sub DrawCloseButton()
DoEvents
SetCursorPos tPoint.x, tPoint.y
End Sub
Private Sub MoveCursor()
GetCursorPos tPoint
SetCursorPos tRect.Right - 15, tRect.Top + 15
Application.OnTime Now + TimeSerial(0, 0, 0.1), _
"DrawCloseButton"
End Sub
'=========Wrapper function===============.
Sub ShowFormatedUserForm( _
_
ByVal Form As Object, _
ByVal CaptionColor As Long, _
Optional ByVal FontColour As Long = vbWhite, _
Optional ByVal FontSize As Long = 12, _
Optional ByVal Bold As Boolean = False)
Call HookUserForm _
_
(ByVal Form, _
ByVal CaptionColor, _
ByVal FontColour, _
ByVal FontSize, _
ByVal Bold)
End Sub
