| '------------------------
' Module: modHook
Option Explicit
Type RECT
left As Long
top As Long
right As Long
bottom As Long
End Type
Type DRAWITEMSTRUCT
CtlType As Long
CtlID As Long
itemID As Long
itemAction As Long
itemState As Long
hwndItem As Long
hdc As Long
rcItem As RECT
itemData As Long
End Type
Public Const TRANSPARENT = 1
Public Const DT_CENTER = &H1
Public Const DT_VCENTER = &H4
Public Const DT_SINGLELINE = &H20
Public Const PS_SOLID = 0
Public Const GWL_WNDPROC = (-4)
Public Const GWL_STYLE = (-16)
Public Const ODS_SELECTED = &H1
Public Const ODS_DISABLED = &H4
Public Const ODS_FOCUS = &H10
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) _
As Long
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
Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest _
As Any, src As Any, ByVal length As Long) As Long
Declare Function CopyRect Lib "user32" (lpDestRect As RECT, lpSourceRect _
As RECT) As Long
Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect _
As RECT) As Long
Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As _
Long, ByVal y As Long) As Long
Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) _
As Long
Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As _
RECT, ByVal hBrush As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) _
As Long
Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal _
crColor As Long) As Long
Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal _
nBkMode As Long) As Long
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
Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal _
nWidth As Long, ByVal crColor As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal _
hObject As Long) As Long
Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x _
As Long, ByVal y As Long) As Long
Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x _
As Long, ByVal y As Long, lpPoint As Any) As Long
Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Declare Function GetDlgCtrlID Lib "user32" (ByVal hwnd As Long) As Long
Declare Function OffsetRect Lib "user32" (lpRect As RECT, _
ByVal x As Long, ByVal y As Long) As Long
Public Const BS_OWNERDRAW = &HB&
Public Const WM_DRAWITEM = &H2B
Public Const WM_NCDESTROY = &H82
Private m_hWndParent As Long
Private m_lpPrevWndProc As Long
Private m_bHooked As Boolean
Private m_colButtons As New Collection
Public Sub DefineColor(frmParent As Form, cmdButton As CommandButton, _
Optional colorFore As Long = vbButtonText, Optional colorBack _
As Long = vbButtonFace, Optional colorDisable As Long = _
vbButtonShadow, Optional nBevel As Long = 2)
Debug.Assert cmdButton.Style = 1
'Command button /must/ be set to Style = 1 - vbGraphical
Dim tmp As New clsButtonInfo
tmp.colorBack = IIf(colorBack < 0, _
GetSysColor(Val("&H" & Mid(Hex(colorBack), 2))), colorBack)
tmp.colorFore = IIf(colorFore < 0, _
GetSysColor(Val("&H" & Mid(Hex(colorFore), 2))), colorFore)
tmp.colorDisable = IIf(colorDisable < 0, _
GetSysColor(Val("&H" & Mid(Hex(colorDisable), 2))), colorDisable)
Set tmp.cmdButton = cmdButton
tmp.nBevel = nBevel
m_colButtons.Add tmp, "-" & Str(GetDlgCtrlID(cmdButton.hwnd))
Dim nStyle As Long
nStyle = GetWindowLong(cmdButton.hwnd, GWL_STYLE)
nStyle = nStyle Or BS_OWNERDRAW
SetWindowLong cmdButton.hwnd, GWL_STYLE, nStyle
If Not m_bHooked Then
Hook frmParent
End If
End Sub
Public Sub Hook(frm As Form)
m_bHooked = True
m_hWndParent = frm.hwnd
m_lpPrevWndProc = GetWindowLong(m_hWndParent, GWL_WNDPROC)
SetWindowLong m_hWndParent, GWL_WNDPROC, AddressOf WndProc
End Sub
Public Sub Unhook()
m_bHooked = False
SetWindowLong m_hWndParent, GWL_WNDPROC, m_lpPrevWndProc
End Sub
Private Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim bPrevProc As Boolean
bPrevProc = True
Select Case uMsg
Case WM_DRAWITEM
On Error Resume Next
Err.Clear
m_colButtons.Item "-" & Str(wParam)
If Err Then
bPrevProc = True
Else
DrawItem lParam, wParam
bPrevProc = False
End If
Err.Clear
Case WM_NCDESTROY
Unhook
End Select
If bPrevProc Then
WndProc = CallWindowProc(m_lpPrevWndProc, hwnd, _
uMsg, wParam, lParam)
End If
End Function
Private Sub DrawItem(lpDIS As Long, ID As Long)
Dim DIS As DRAWITEMSTRUCT
CopyMemory DIS, ByVal lpDIS, Len(DIS)
Dim rectFocus As RECT
Dim rectButton As RECT
CopyRect rectFocus, DIS.rcItem
CopyRect rectButton, DIS.rcItem
rectFocus.left = rectFocus.left + 4
rectFocus.right = rectFocus.right - 4
rectFocus.top = rectFocus.top + 4
rectFocus.bottom = rectFocus.bottom - 4
DrawFilledRect DIS.hdc, rectButton, _
m_colButtons.Item("-" & Str(ID)).colorBack
DrawFrame DIS.hdc, rectButton, _
m_colButtons.Item("-" & Str(ID)).nBevel
DrawButtonText DIS.hdc, rectButton, _
m_colButtons.Item("-" & Str(ID)).cmdButton.Caption, _
m_colButtons.Item("-" & Str(ID)).colorFore, DIS.itemState
If DIS.itemState And ODS_FOCUS Then
DrawFocusRect DIS.hdc, rectFocus
If DIS.itemState And ODS_SELECTED Then
DrawFilledRect DIS.hdc, rectButton, _
m_colButtons.Item("-" & Str(ID)).colorBack
DrawFrame DIS.hdc, rectButton, _
-m_colButtons.Item("-" & Str(ID)).nBevel
DrawButtonText DIS.hdc, rectButton, _
m_colButtons.Item("-" & Str(ID)).cmdButton.Caption, _
m_colButtons.Item("-" & Str(ID)).colorFore, _
DIS.itemState
DrawFocusRect DIS.hdc, rectFocus
End If
ElseIf DIS.itemState And ODS_DISABLED Then
DrawButtonText DIS.hdc, rectButton, _
m_colButtons.Item("-" & Str(ID)).cmdButton.Caption, _
m_colButtons.Item("-" & Str(ID)).colorDisable, _
DIS.itemState
End If
End Sub
Private Sub DrawFrame(hdc As Long, r As RECT, Inset As Long)
Dim colorDark As Long
Dim colorLight As Long
Dim colorTL As Long
Dim colorBR As Long
Dim i As Long
Dim m As Long
Dim width As Long
width = Abs(Inset)
For i = 0 To width - 1
m = 255 / (i + 2)
colorDark = PaletteRGB(m, m, m)
m = 192 + (63 / (i + 1))
colorLight = PaletteRGB(m, m, m)
If width = 1 Then
colorLight = RGB(255, 255, 255)
colorDark = RGB(128, 128, 128)
End If
If Inset < 0 Then
colorTL = colorDark
colorBR = colorLight
Else
colorTL = colorLight
colorBR = colorDark
End If
DrawLine2 hdc, r.left, r.top, r.right, r.top, colorTL
DrawLine2 hdc, r.left, r.top, r.left, r.bottom, colorTL
If (Inset < 0) And (i = width - 1) And (width > 1) Then
DrawLine2 hdc, r.left + 1, r.bottom - 1, _
r.right, r.bottom - 1, RGB(1, 1, 1)
DrawLine2 hdc, r.right - 1, r.top + 1, _
r.right - 1, r.bottom, 0
Else
DrawLine2 hdc, r.left + 1, r.bottom - 1, _
r.right, r.bottom - 1, colorBR
DrawLine2 hdc, r.right - 1, r.top + 1, _
r.right - 1, r.bottom, colorBR
End If
InflateRect r, -1, -1
Next
End Sub
Private Sub DrawFilledRect(hdc As Long, r As RECT, color As Long)
Dim brush As Long
brush = CreateSolidBrush(color)
FillRect hdc, r, brush
DeleteObject brush
End Sub
Private Sub DrawLine(hdc As Long, rectEndPoints As RECT, color As Long)
Dim penNew As Long
Dim penOld As Long
penNew = CreatePen(PS_SOLID, 1, color)
penOld = SelectObject(hdc, penNew)
MoveToEx hdc, rectEndPoints.left, rectEndPoints.top, ByVal 0
LineTo hdc, rectEndPoints.right, rectEndPoints.bottom
SelectObject hdc, penOld
DeleteObject penNew
End Sub
Private Sub DrawLine2(hdc As Long, left As Long, top As Long, _
right As Long, bottom As Long, color As Long)
Dim penNew As Long
Dim penOld As Long
penNew = CreatePen(PS_SOLID, 1, color)
penOld = SelectObject(hdc, penNew)
MoveToEx hdc, left, top, ByVal 0
LineTo hdc, right, bottom
SelectObject hdc, penOld
DeleteObject penNew
End Sub
Private Sub DrawButtonText(hdc As Long, r As RECT, _
strText As String, color As Long, state As Long)
Dim colorPrev As Long
colorPrev = SetTextColor(hdc, color)
SetBkMode hdc, TRANSPARENT
Dim rectTemp As RECT
CopyRect rectTemp, r
If state And ODS_SELECTED Then
OffsetRect rectTemp, 1, 1
End If
DrawText hdc, strText, Len(strText), rectTemp, _
DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
SetTextColor hdc, colorPrev
End Sub
Private Function PaletteRGB(r As Long, g As Long, b As Long) As Long
PaletteRGB = RGB(r, g, b) Or &H2000000
End Function
' End of Module
'------------------------
'------------------------
' Class: clsButtonInfo
Public colorFore As Long
Public colorBack As Long
Public colorDisable As Long
Public nBevel As Long
Public cmdButton As CommandButton
' End of class
'-------------------------
|