MSG_BEFORE = 1 'Callback before the original WndProc
MSG_AFTER = 2 'Callback after the original WndProc
MSG_BEFORE_AFTER = MSG_BEFORE Or MSG_AFTER 'Callback before and after the original WndProc
End Enum
Private Const ALL_MESSAGES As Long = -1 'All messages callback
Private Const MSG_ENTRIES As Long = 32 'Number of msg table entries
Private Const CODE_LEN As Long = 240 'Thunk length in bytes
Private Const WNDPROC_OFF As Long = &H30 'WndProc execution offset
Private Const MEM_LEN As Long = CODE_LEN + (8 * (MSG_ENTRIES + 1)) 'Bytes to allocate per thunk, data + code + msg tables
Private Const PAGE_RWX As Long = &H40 'Allocate executable memory
Private Const MEM_COMMIT As Long = &H1000 'Commit allocated memory
Private Const GWL_WNDPROC As Long = -4 'SetWindowsLong WndProc index
Private Const IDX_SHUTDOWN As Long = 1 'Shutdown flag data index
Private Const IDX_HWND As Long = 2 'hWnd data index
Private Const IDX_EBMODE As Long = 3 'EbMode data index
Private Const IDX_CWP As Long = 4 'CallWindowProc data index
Private Const IDX_SWL As Long = 5 'SetWindowsLong data index
Private Const IDX_FREE As Long = 6 'VirtualFree data index
Private Const IDX_ME As Long = 7 'Owner data index
Private Const IDX_WNDPROC As Long = 8 'Original WndProc data index
Private Const IDX_CALLBACK As Long = 9 'zWndProc data index
Private Const IDX_BTABLE As Long = 10 'Before table data index
Private Const IDX_ATABLE As Long = 11 'After table data index
Private Const IDX_EBX As Long = 14 'Data code index
Private z_Base As Long 'Data pointer base
Private z_Funk As Collection 'hWnd/thunk-address collection
Private z_TblEnd As Long 'End of the vTable
Private z_Code(29) As Currency 'Thunk machine-code initialised here
Private Declare Function CallWindowProcA Lib "user32" (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 GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowPos Lib "user32.dll" (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 ScreenToClient Lib "user32.dll" (ByVal hwnd As Long, ByRef lpPoint As RECT) As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function OffsetRect Lib "user32.dll" (ByRef lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetWindowDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function FrameRect Lib "user32.dll" (ByVal hDC As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
Private Declare Function GetParent Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function InflateRect Lib "user32.dll" (ByRef lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function InvalidateRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As Any, ByVal bErase As Long) As Long
Private Declare Function UpdateWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function Rectangle Lib "gdi32.dll" (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 CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function GetBkColor Lib "gdi32.dll" (ByVal hDC As Long) As Long
Private Declare Function MoveToEx Lib "gdi32.dll" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByRef lpPoint As Any) As Long
Private Declare Function LineTo Lib "gdi32.dll" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetGDIObject Lib "gdi32.dll" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
Private Const SWP_FRAMECHANGED As Long = &H20
Private Const SWP_NOACTIVATE As Long = &H10
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOOWNERZORDER As Long = &H200
Private Const SWP_NOSENDCHANGING As Long = &H400
Private Const SWP_NOSIZE As Long = &H1
Private Const SWP_NOZORDER As Long = &H4
Private Const WS_EX_CLIENTEDGE As Long = &H200&
Private Const WS_BORDER As Long = &H800000
Private Const WM_NCPAINT As Long = &H85
Private Const WM_PAINT As Long = &HF&
Private Const WM_DRAWITEM As Long = &H2B
Private Const GWL_STYLE As Long = -16
Private Const GWL_EXSTYLE As Long = -20
Private Const SM_CYBORDER As Long = 6
Private Const SM_CYEDGE As Long = 46
Private Const COLOR_BTNHIGHLIGHT As Long = 20
Private Const COLOR_BTNSHADOW As Long = 16
Private Const COLOR_3DDKSHADOW As Long = 21
Private Const COLOR_3DLIGHT As Long = 22
Private Const COLOR_WINDOWFRAME As Long = 6
Private Const LBS_NOINTEGRALHEIGHT As Long = &H100&
Private Const CBS_NOINTEGRALHEIGHT As Long = &H400&
Private Const WM_CTLCOLOREDIT As Long = &H133
Private Const WM_CTLCOLORLISTBOX As Long = &H134
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 Settings() As Long
Public Enum Specialcolors 'sneaky way of exposing public "constants" from a class
bsSysDefault = -2
bsAutoShade = -1
End Enum
Public Enum BorderStyleOptions
[_bs_Max] = 3
[_bsBackColor] = -3
bsFlat1Color = 0 ' 1 color, 1 pixel border around control
bsFlat2Color = 1 ' 2 color, 1 pixel border
bsSunken = 2 ' 4 color, 2 pixel border
bsRaised = 3 ' 4 color, 2 pixel border
' bsNone = 4 ' no borders at all -- not coded/not sure it will be
End Enum
Public Enum vbControlType
ctOther = 0 ' controls that have a true border (non-client area)
ctComboBox = 1 ' some draw on client and some on non-client
ctImageCombo = 2 ' owner-drawn by VB
ctListBox = 3 ' control height can change when changing border styles
ctTextBox = 4 ' when flat style, VB draws border on client area
End Enum
Private Borders As Collection
Public Sub SetBorder(ByVal hwnd As Long, BorderStyle As BorderStyleOptions, _
Optional ByVal ctrlType As vbControlType = ctOther, _
Optional ByVal Shadow As Long = vbButtonShadow, _
Optional ByVal DarkShadow As Long = bsAutoShade, _
Optional ByVal Highlight As Long = bsAutoShade, _
Optional ByVal LightShadow As Long = bsAutoShade)
' The control will be subclassed to allow custom borders. Therefore it is
' best to call ResetBorder on any control loaded with Controls.Add before
' that control is removed if you sent that added control here.
' ///// Border Styles \\\\\
' bsFlat1Color. Solid 1-pixel border, 1 color (i.e., flat).
' Uses Shadow only
' bsFlat2Color. Left/Top borders are 1 color, right/bottom are another
' Uses Shadow & Highlight only
' bsSunken. Left/Top outer border are Shadow, Right/Bottom outer are HighLight
' Left/Top inner border are DarkShadow, Right/Bottom inner are LightShadow
' bsRaised. Left/Top outer border are HighLight, Right/Bottom outer are DarkShadow
' Left/Top inner border are LightShadow, Right/Bottom outer are Shadow
' ///// colors \\\\\ vb system colors can be passed
' Shadow: 2nd darkest of 4 color borders; color for a single color border
' DarkShadow: the darkest of 4 color borders
' LightShadow: 2nd lightest of 4 color borders
' Highlight: lightest of 4 color borders
' Special values for the above 4 colors
' -1 = AutoShade. DarkShadow, LightShadow & Highlight are shades of Shadow
' DarkShadow = Shadow darkened to 15% from black
' LightShadow = Shadow lightened by 85% of its lightest value (white)
' Highlight = Shadow lightened by 100% (or vbWhite)
' -2 = System colors: vb3DDKShadow, vbButtonShadow, vb3DLight, vbHighlight respectively
' -3 & -4 (Reserved) are used by the class to fake single borders on combo boxes
' ///// Control Type \\\\\
' Some controls have their borders drawn by VB on the control's client area whereas
' others are drawn in the non-client area as expected. Think of a form with no
' borders but you want borders so you draw it on the form (non-client area).
' VB combo boxes are very much like that scenario. Therefore, the control type
' needs to be known in advance so the class can handle those special cases.
' There are more special cases too & those known are handled herein
' ctComboBox: use for comboboxes and drivecombo
' ctImageCombo: use for the image combobox
' ctListBox: use for listboxes and file listboxes
' ctTextBox: use for the textbox control
' ctOther: use for other controls like treeview, listview, progressbar, etc
' sanity checks first & don't allow user to pass a reserved color code
If BorderStyle < bsFlat1Color Or BorderStyle > [_bs_Max] Then Exit Sub
If DarkShadow = -3 Or DarkShadow = -4 Then DarkShadow = 0
If LightShadow = -3 Or LightShadow = -4 Then LightShadow = 0
If Shadow = -3 Or Shadow = -4 Then Shadow = 0
If Highlight = -3 Or Highlight = -4 Then Highlight = 0
Dim Index As Long, lFlags As Long, isSubclassed As Boolean
Dim lExStyle As Long, lStyle As Long, lOldStyle As Long
Dim cHwnd As Long, wRect As RECT, cRect As RECT
Dim borderSize As Long, borderSizeNew As Long
' flags for special case control scenarios
Dim bIntegralHT As Boolean, bFlatTextBox As Boolean, bHasBorder As Boolean
On Error Resume Next
If Borders Is Nothing Then ' first time thru
Set Borders = New Collection
Index = 1
ReDim Settings(1 To 8)
Borders.Add Index, "h" & hwnd
Else
Index = Borders("h" & hwnd) ' been here before, is this hWnd already ours?
If Index = 0 Then ' nope, set it up
Index = UBound(Settings) + 1
ReDim Preserve Settings(1 To Index + 7)
Borders.Add Index, "h" & hwnd
If Err Then Err.Clear
Else
isSubclassed = True ' yep, use cached settings
End If
End If
' cache colors & style settings
Settings(Index) = CLng(BorderStyle Or (ctrlType * &H100&))
Settings(Index + 1) = Shadow
Settings(Index + 2) = Highlight
Settings(Index + 3) = DarkShadow
Settings(Index + 4) = LightShadow
Settings(Index + 7) = hwnd ' needed when re-indexing if control is unsubclassed
If isSubclassed Then
lStyle = Settings(Index + 5)
lExStyle = Settings(Index + 6)
Else
lExStyle = GetWindowLong(hwnd, GWL_EXSTYLE)
lStyle = GetWindowLong(hwnd, GWL_STYLE)
Settings(Index + 5) = lStyle
Settings(Index + 6) = lExStyle
End If
' setwindowpos flags
lFlags = SWP_FRAMECHANGED Or SWP_NOACTIVATE Or SWP_NOMOVE Or SWP_NOOWNERZORDER Or SWP_NOSIZE Or SWP_NOZORDER
' special case for combo boxes. We can't remove the borders on these, because
' they really aren't borders for the most part; they are drawn on the client
' ComboBox.Style=1 is an exception. It has borders come from its child's borders,
' but to make things a little bit easier we will treat all combos the same
If ctrlType = ctComboBox Or ctrlType = ctImageCombo Then
If BorderStyle = bsFlat2Color Or BorderStyle = bsFlat1Color Then
' to fake a 1-pixel border, we will draw the inner level of borders
' in the same backcolor as the control. Special flags are set for this.
' Note: GetBkColor does not return the control's BackColor property.
' These controls are sent a wm_ctlcoloredit or wm_ctlcolorlistbox message
' forcing the parent object to provide the bacground color brush
Settings(Index + 3) = [_bsBackColor]
Settings(Index + 4) = [_bsBackColor] - 1
' normally a 1 pixel border only requires 2 colors and only an outer border
' however, we'll tweak so 4 colors are used & also an inner border
Settings(Index) = CLng(bsSunken Or (ctrlType * &H100&))
If BorderStyle = bsFlat1Color Then Settings(Index + 2) = Settings(Index + 1)
End If
Else
' combo styles are not modified, but color tweaked above to appear so
Select Case BorderStyle
Case bsFlat1Color, bsFlat2Color
If ctrlType = ctTextBox Then
' another exception: textbox with flat border style draws border on client
If (lExStyle And WS_EX_CLIENTEDGE) = 0 Then ' flat?
lStyle = lStyle And Not WS_BORDER
bFlatTextBox = True
Else
lStyle = lStyle Or WS_BORDER
End If
Else
lStyle = lStyle Or WS_BORDER
End If
lExStyle = lExStyle And Not WS_EX_CLIENTEDGE
Case Else
If ctrlType = ctTextBox Then
' another exception: textbox with flat border style draws border on client
If (Settings(Index + 6) And WS_EX_CLIENTEDGE) = 0 Then ' flat?
' we need 2 borders, one drawn on client & we provide the 2nd one via WS_Border
lStyle = lStyle Or WS_BORDER
lExStyle = lExStyle And Not WS_EX_CLIENTEDGE
bFlatTextBox = True
Else
lStyle = lStyle And Not WS_BORDER
lExStyle = lExStyle Or WS_EX_CLIENTEDGE
End If
Else
lStyle = lStyle And Not WS_BORDER
lExStyle = lExStyle Or WS_EX_CLIENTEDGE
End If
End Select
' now should a user be setting a listbox (IntegralHeight=True) border to
' raised/sunken when it was previously set to flat, simply changing the borderstyles
' will result in the listbox shrinking in size. We should account for that
' get current bordersize
lOldStyle = GetWindowLong(hwnd, GWL_STYLE)
' get current bordersize
If (lOldStyle And WS_BORDER) = WS_BORDER Then
borderSize = GetSystemMetrics(SM_CYBORDER)
bHasBorder = True
End If
If (GetWindowLong(hwnd, GWL_EXSTYLE) And WS_EX_CLIENTEDGE) = WS_EX_CLIENTEDGE Then
RtlMoveMemory z_Base, VarPtr(z_Code(0)), CODE_LEN 'Copy the thunk to the allocated memory
On Error GoTo Catch 'Catch double subclassing
z_Funk.Add z_Base, "h" & lng_hWnd 'Add the hWnd/thunk-address to the collection
On Error GoTo 0
zData(IDX_EBX) = z_Base 'Patch the data address
zData(IDX_HWND) = lng_hWnd 'Store the window handle in the thunk data
zData(IDX_BTABLE) = z_Base + CODE_LEN 'Store the address of the before table in the thunk data
zData(IDX_ATABLE) = zData(IDX_BTABLE) + ((MSG_ENTRIES + 1) * 4) 'Store the address of the after table in the thunk data
zData(IDX_WNDPROC) = _
SetWindowLongA(lng_hWnd, GWL_WNDPROC, z_Base + WNDPROC_OFF) 'Set the new WndProc and store the original WndProc in the thunk data
sc_Subclass = True 'Indicate success
Exit Function 'Exit
Catch:
zError "sc_Subclass", "Window handle is already subclassed"
End Function
'Terminate all subclassing
Private Sub sc_Terminate()
Dim I As Long
Dim nAddr As Long
If z_Funk Is Nothing Then 'Ensure that subclassing has been started
zError "sc_UnSubAll", "Subclassing hasn't been started", False
Else
With z_Funk
For I = .Count To 1 Step -1 'Loop through the collection of window handles in reverse order
nAddr = .Item(I) 'Map zData() to the hWnd thunk address
If IsBadCodePtr(nAddr) = 0 Then 'Ensure that the thunk hasn't already freed itself
z_Base = nAddr 'Map the thunk memory to the zData() array
sc_UnSubclass zData(IDX_HWND) 'UnSubclass
End If
Next I 'Next member of the collection
End With
Set z_Funk = Nothing 'Destroy the hWnd/thunk-address collection
End If
End Sub
'UnSubclass the specified window handle
Public Sub sc_UnSubclass(ByVal lng_hWnd As Long)
If z_Funk Is Nothing Then 'Ensure that subclassing has been started
zError "UnSubclass", "Subclassing hasn't been started", False
Else
zDelMsg lng_hWnd, ALL_MESSAGES, IDX_BTABLE 'Delete all before messages
zDelMsg lng_hWnd, ALL_MESSAGES, IDX_ATABLE 'Delete all after messages
z_Base = zMap_hWnd(lng_hWnd) 'Map the thunk memory to the zData() array
zData(IDX_SHUTDOWN) = -1 'Set the shutdown indicator
z_Funk.Remove "h" & lng_hWnd 'Remove the specified window handle from the collection
End If
End Sub
'Add the message value to the window handle's specified callback table
Private Sub sc_AddMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = eMsgWhen.MSG_AFTER)
If When And MSG_BEFORE Then 'If the message is to be added to the before original WndProc table...
zAddMsg lng_hWnd, uMsg, IDX_BTABLE 'Add the message to the before table
End If
If When And MSG_AFTER Then 'If message is to be added to the after original WndProc table...
zAddMsg lng_hWnd, uMsg, IDX_ATABLE 'Add the message to the after table
End If
End Sub
'Delete the message value from the window handle's specified callback table
Private Sub sc_DelMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = eMsgWhen.MSG_AFTER)
If When And MSG_BEFORE Then 'If the message is to be deleted from the before original WndProc table...
zDelMsg lng_hWnd, uMsg, IDX_BTABLE 'Delete the message from the before table
End If
If When And MSG_AFTER Then 'If the message is to be deleted from the after original WndProc table...
zDelMsg lng_hWnd, uMsg, IDX_ATABLE 'Delete the message from the after table
End If
End Sub
'Call the original WndProc
Private Function sc_CallOrigWndProc(ByVal lng_hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
z_Base = zMap_hWnd(lng_hWnd) 'Map zData() to the thunk of the specified window handle
sc_CallOrigWndProc = _
CallWindowProcA(zData(IDX_WNDPROC), lng_hWnd, uMsg, wParam, lParam) 'Call the original WndProc of the passed window handle parameter
End Function
'Add the message to the specified table of the window handle
Private Sub zAddMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, ByVal nTable As Long)
Dim nCount As Long 'Table entry count
Dim I As Long 'Loop index
z_Base = zMap_hWnd(lng_hWnd) 'Map zData() to the thunk of the specified window handle
z_Base = zData(nTable) 'Map zData() to the table address
If uMsg = ALL_MESSAGES Then 'If ALL_MESSAGES are being added to the table...
nCount = ALL_MESSAGES 'Set the table entry count to ALL_MESSAGES
Else
nCount = zData(0) 'Get the current table entry count
If nCount >= MSG_ENTRIES Then 'Check for message table overflow
zError "zAddMsg", "Message table overflow. Either increase the value of Const MSG_ENTRIES or use ALL_MESSAGES instead of specific message values", False
Exit Sub
End If
For I = 1 To nCount 'Loop through the table entries
If zData(I) = 0 Then 'If the element is free...
zData(I) = uMsg 'Use this element
Exit Sub 'Bail
ElseIf zData(I) = uMsg Then 'If the message is already in the table...
Exit Sub 'Bail
End If
Next I 'Next message table entry
nCount = I 'On drop through: i = nCount + 1, the new table entry count
zData(nCount) = uMsg 'Store the message in the appended table entry
End If
zData(0) = nCount 'Store the new table entry count
End Sub
'Delete the message from the specified table of the window handle
Private Sub zDelMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, ByVal nTable As Long)
Dim nCount As Long 'Table entry count
Dim I As Long 'Loop index
z_Base = zMap_hWnd(lng_hWnd) 'Map zData() to the thunk of the specified window handle
z_Base = zData(nTable) 'Map zData() to the table address
If uMsg = ALL_MESSAGES Then 'If ALL_MESSAGES are being deleted from the table...
zData(0) = 0 'Zero the table entry count
Else
nCount = zData(0) 'Get the table entry count
For I = 1 To nCount 'Loop through the table entries
If zData(I) = uMsg Then 'If the message is found...
zData(I) = 0 'Null the msg value -- also frees the element for re-use
Exit Sub 'Exit
End If
Next I 'Next message table entry
zError "zDelMsg", "Message &H" & Hex$(uMsg) & " not found in table", False
End If
End Sub
'Error handler
Private Sub zError(ByVal sRoutine As String, ByVal sMsg As String, Optional ByVal bEnd As Boolean = True)
'Return the address of the specified DLL/procedure
Private Function zFnAddr(ByVal sDLL As String, ByVal sProc As String) As Long
zFnAddr = GetProcAddress(GetModuleHandleA(sDLL), sProc) 'Get the specified procedure address
Debug.Assert zFnAddr 'In the IDE, validate that the procedure address was located
End Function
'Map zData() to the thunk address for the specified window handle
Private Function zMap_hWnd(ByVal lng_hWnd As Long) As Long
If z_Funk Is Nothing Then 'Ensure that subclassing has been started
zError "z_Base = zMap_hWnd", "Subclassing hasn't been started", True
Else
On Error GoTo Catch 'Catch unsubclassed window handles
zMap_hWnd = z_Funk("h" & lng_hWnd) 'Get the thunk address
z_Base = zMap_hWnd 'Map zData() to the thunk address
End If
Exit Function 'Exit returning the thunk address
nCount = zData(0ae Sub zDel zData(0ae Sub itart)S e 'If the 4XHo the1 49) = 843649688964536e message from tta(0ae Sunt = tart)S e=9a(0ae Sub itartabl 4XHo the1 49) = 843649688964536e =.b IocAddressunction ed<number o lassi ExiSubS_MESSAGES
'GeH SahWnd) u6ubalidate 49nd) , 'Ma<AGES
'GeHhandle
z_Base = zData(nTable) b_Base = zDWnd on ed<number o lassi ExiSubS_MESSAGES
'Gdleort)S e=9a(0ae Su 'Next message table entry
zErr 'Store m
zEt) As Long
' Conver- o IDX_ATA beleort)S e=9a(0ae Su mBtr displays it. (axRG )Is And Nod<numbs been started
Fla the zData()pe = g nt)8Oodz_Base = eb,wnd", "Subcla o Addr(ByVal sDLL u()pe he table entry cor displaysnWP_NOMOVE
o-use
Exit Ss Long)
zData() to the thunk of the specified window handle
z_Base hWnd(s
DBase = zDWnd on ed<number
nt
&817@: z_Codce LonnOodz_B' ConvzDatNE(0ae h8g"6>a E ssert IDXeb,wning the bor zEt) As LongH16= )S Xeb,wning th) vbCritical, 7-77i, Xeb,wningt mess16= )S Xeb3 u6ug th them the after, 7-77i, XebgHcal, 7-77i, Xeb,.536e message fort)S e= bIing g, Optional ByVal When As eMsgWhen = eMsgWhen. S
'Gdleor0ae Sub zD= bD "Error in "7ubcla o W) As Lotry count
If nCount >= MSG_ENTRIES OrAf 'Caginal WndProc table...
zAdd8 sg(B ALL_MESSAGES are being deletev8458374ot the table Else
of the final privng 3v beleort)S e=9a(0ae Su mb3 uo
e
'EeS.en And MSG_BE) As Lotry count
If nCount >= MSG_ENTRIES OrAf RIES OrAmmmmmmmmmmmmmmmm5&ied window handle
ed window Rcoun>ase = zDWna(0ae h8gext
End IfE) A9hunkFbbbbb = lEHe
ed winMX) 'Allocate 9rhunk of the specifie16= )S Xeb,wning th) 'Bail
ElseIf zData(I) = uMsg Then End If 'Get the 6Rs Stringf nC e Su 'Next fie1e Exit Subs to mmmmmmmmmmm5&ieehat suIES OrAf RIE&ieeh - 36ning t nCount 'Store the neHe
ed wipI e SuuuuuuuuuuuwindowLL_MESSAGES are being deletev8458374ot the tab 'Bail
le", clienail
c
z-rssed window handle parameter
End Function
'Add the message to the sn
'Ba X_FREE) ) = )S 8 lng_hWnd, uMsg, IDX_A g = ALL_MESSAGES Then LL_MESSAGEet g = ALL_MESmmmng th) vbCStoreed wipI e Su60AGES a= )S e.eC End ' Sub zDel zData(0ae Sub iy As )hat e RIE&ieeh - 36nin entry count
If nCount >= MSG_dN 37bwindow (>2 'If messagly Luminance iss(G X<7indaTEDGE) = WS_ As )hat e RIE& g = ALL_MES g = ALL_ME
E) = g = ALL_MtFindow (>2 SGeH SahhanF) = g = ALL_MtFindow (>2cLong
Dim bIntegguy.uTC lassi (bn- sc_CallO As 'Ensure that subclassing has been s = g 'LL_MESSAGES areI 'On drop through: As Long) As Long
If z_Funk Is Nothing Then M = zFnAddr("kernel32"nk data
ress for the speci in the appended t88888ernelop through: As Lont as needed
zData(I)NuleHannt D2R79hat suIES OrAf RIE&ieeh - 36nior(ByVsc_CallO As 'Ensure thMES g = ALL_ME
>2 'If messagly 1_Base hWn( sc_UnSubclasO s 8Base 0&ieeh Addr(ByVal sDLL ' Sub z&ieeh Addro ms Nothing T eh Addro ms Nothing T eh Addro ms Nothing T omments, see SetBordor Addr(ByVal sDL b_gt G_dN 37bESSAn85 hinAllo 't
If n-a, ByVal sPrvate Sub zEcLong
Dim bIntegguyyyyyyyyyyy(0ae h8gexBLNothing T ure thMES g = ALL_ME
>2 'If messagly 1_Base hWn( sc_UnSubclasO k of t374 (>2cLo3c_UnSubclas374 (>2cLo3c_UnSubclas374 (>2cLn( sc_UnSubclasO s 8Base 0&iee7o3c&eWn( sc_U,ipI e Su7nn removin (>2cclasO r-lount 2cLo3c_UnSubcla 22ccla k ofG- ALL sc_U,ipI e Su7nn removin (>2cclasO r-lount 2cLo3c_UnSubcla 2cLo3cnSubclasO s, see G_dN 37bESSAn85 hinAllo 't
If n-a, ByVal sltDtUnSubcla 2cLo3cnSu = : As Long)If bIntegralHT 'IfL$ Hue = Hue * 60/ hWnd thu k otd
On Hue * 60/60/ hWnd thu k otd
On Hue * 6Hue * 60 On 16", "EbMode") speci zData(dESSAG . SaturclasO hmm5&ie Bess
pmtegralHT 'IfL$ Hue = Hue * 60/ hWnd thu ElseI& 'IfLzData(dESci WI& s bD "Error in "7ubcla o W) As Lotry count
If nCount >= MSG_ENTRIES OrAf 'Caginal WndProc table...
zAdd8 sg(B ALL_MESSAGES are being deletev8458374ot the table Else
ALL_MESSAGES are bei.P RIE&ieeh hisSu = : As Long)If bIntegralHT 'IfL$ Hue = Hue * 60/ hWnd thu k otre bei.P RIE&ieeh e...
drop treeh border on non-client
bei.P >a6 wipI e Su6s Single, miB ALL_MESSAGES are being deletev8458374ot 'IfL$ H6,v on-cl' treeh bo wipI e Su6s Sthe after tablerninnnnnnnnnnnn Lon bo wipI e t
pmtegralHT 'IfL$ Hue = Hue * 60/ hWnd thu ElseI& 'If bei.P* 60/ hWneb,wnng_h lFlags = lFle element for ao IIIIIIIIIIII/"Error in "7u * 6Hue *e 5bEns5being deletev8Be Sthe84ot thP, 'Store thes Long) As Long
If z_Funk Is Nothing Then M = zFnAddr("kernel32"nk data
ress for thdr("kkernel32"nk data
ress for thdr("kkernel32"nk data
ress for thdr("kkernel32"nk data
ress unt the tabtress for thdr("kkernel32"nk data
ress unt the tabtress for thdr("kkernel3nnnnnnnnnnnh Addro ms Nothing T o3c_UnSubcla 2cL8Base If nnSubcluuuuuuuuuwindowLL_MESSAGclas374 (>2cLn( sc_UnSubclasO 2o_Subclass", "Window hanata
ress untALL_MESSAGES are beiHng, ByVal nTable As Longv8Be e 9 'Ma<AG3 s for we RIE& 'IfL$4cyj for thdr(" Lon bo wipI e snt $4cyj for tosgWhOn Hue * 6H"sount handlE& privn* 6Hu nT 2cL8Base If nnSubcluuuuuuuuuwindowLL_MESSAGclas374 (>H= MSG_ENTRIES OrAf thes Long) As Long
If z_Funk Is Nothing Then Mthe b0yVal sRoutineeeeeee NsO '''''' NsO he speciLL e.,t
Ifitical, = zData nd iWnd) ", "SetWindowL 1_Base cT5te the least RGB valuagesy NsO '''''' oIfinTabl37bESSAn85 As oG_ENTRIES ndong
Dim bIn ztALL_MESSAG1_Base dong
Dim bIy(g_h B k otd
On Hue * 6Hue k otd
On Hue * 6 t7Hue * 6 t -< t7Hueare being deletev8458374ot 'IfL$ H6,v on-cl' tGclas374 (>2cLn(nt h("kkernel32"nk dattttttttttttttttttttttttttttMO2"nk datttttt . 'IfL$ ieast RGB valu.&ess for th ALL_ME
If n-a, ByVal bIn ztALL_M ''' DLlFhhhhhhhhhhhhhhhhh. HueESSAGES Then LL) =_MEying & lnmc ne< zDelMsg lRLL)inAlfor thdr(" Lon bo wipI e snt Bordor Addr(Bye16", 174 -nel32"nk datttttttttttttttalu.RIE& 'IfL$ clas3l ByVa 2cwe RI\7 C)Nuerflow
zError "zAddMsg", "Message table overflow. Either increase the value of Const MSG_ENTR5beingdl bIn e snt,onst MSG_ENTR(>2cLn(nt h("85 Ei,bs been started
zEth PMSG_ENTR(>2cLn(nt h("85 Ei, ne< llas3l ByVa 2c
\ified window ha 2cLo3c_UnSubcla =Lo3c_I0 =Lo3c_I0att, ByVByeCo Elsep =Lo3c_I0On Errlocated =o3cnSubclasO s, see4nCrror in "7u * 6H9 +t
M th) vbCStoreed $r n88 lFlagsO o3c_I0 nst MSG_ENT e snt dow 1& the thu Ei,bs b ns(3 delyeCodow hlng_hWXbs b ns(3 delyeCodow hlng_hWXbs b ns(3 delyeCodow hlng_hWXran", "Messa fo eCo ,bclasO aseF Tl JF"n ALL_M58374ot d 60c happWif-TR(>2cLn(nt ted 'Stor d 60c thhWXran", d:ifeIIIII7n60c happWifyingAGclas374 (1ode(28) = -4888724176 bo wipI e ty F9ror "zAdd"zAddMsg", "Me)AohWXraasO UnSub174 -nel32"nk datttttttttttttt_ENTR5beingdl bIn e 3FC If n-a, uWXran",, zDelMle", clienail cnSubcrted
zEN-lienail cnSubcrt zEr174 aturX0 sDLLv 4ttttttt happWAs Long
r AddrnSun-a, uWNothing Then )r tosglien ' e 3FC IIIIIIII/"Ep"cnSubcrted
zE hi,
' to how the color picke H6,v on-cl F9ror "zAdd"zAddMsg", "Me)AohWXraasO or Addr(ByVal sDL hi,
' to how t hanehd thu k otd
On Hue * 6Hue * 60 On 16", "EbMode") 2
zErs Long g d3bbbbbbHue ksPrva,s, see4nCrrc" 'Stor d 60c thhWzB)S Xeb,wning th) AohWXraasO UnSub174 -nel32"nkt AohWXraasO to how t hanehd t=Lo3c_I0 ing delet_dNeCo uhes Long) As Long
If z_Funk Is Nothing Then Mthe b0yVal sRoutineeeeeee NsO '''''' NsO he speciLL e.,t
I'''cli9Xeb,wning ttttttt ks'RRRRRRRRRRRRRRRRRRRRRRRRRR '''lzB)S Xeb,wning th) Aoh (Hue < 0th) AohWXr 4tttttt Lu NsO he speciLL e.,t
6N& e.,rSA 3mnail Stor d9 otd6sDLLv 2o_Su MbclazFnAddr(" e.,tn-cl ztAL speciLLlu datm snnnnnnnnnnnn s) =_METT d 6h lFleEp32", GHsppWispeciLLlu eaoRRRR 2F d 6h 3FC IIIIII2F da 2F d 6h 3FC f, thu Ei,e( lFl1tttD being d9eciLL 8Xr ttttzspe IIIIII2F da 2F d 6h 3FC d9 ytt happA2",Wnd) Subtings) - 8)
End If
' force repaint. SetWindowPos seems not to do this for all controls
If e)AohWXra eaoRRRR 2F d 6h 3FC IIIIII2F da 2F d 6h 3FC f, thu Ei,e( lFl1tttD being d9eciLL 8Xr ttttzspe IIIIII2F da 2F d 6h 3FC d9 ytt happA2",Wnd) Subtings) - 8)
End IbbbbbbbbbbbbcnSubclasO e = "h o U d nE hi,
' to how the color pihpe IIIIII288IfL$ t 3Subcla epnd) 60 bs b rdle
Pubs
If e) 'Map zDatsee4n96hpe IISAGES ar ' force reeeeeeee - 8)c l1tttD beinclaMd 6h 3FC d5ove MbclazFnAddr(" e.,teing dattttttttubtings) - 8)
6u EzD obclas) =_METTee7o3c&ehing T Tee7o3c&ehinhWnde7o3c&ehinhWnde7N 37bESSAn0A 6e.,8 lr AddrnSS-te value from the wi. As 71l174 -bcl < e.m etnAlfor thdr('''c
End SubhWnde7o3c&ehi6he a 3T1turation * 1lbhWndea c lzDat 6h WP) = z0his cl < i 7D 7D
