[MSG_AFTER] = 1 'Message calls back after the original (previous) WndProc
[MSG_BEFORE] = 2 'Message calls back before the original (previous) WndProc
[MSG_BEFORE_AND_AFTER] = MSG_AFTER Or MSG_BEFORE 'Message calls back before and after the original (previous) WndProc
End Enum
Private Const ALL_MESSAGES As Long = -1 'All messages added or deleted
Private Const CODE_LEN As Long = 197 'Length of the machine code in bytes
Private Const GWL_WNDPROC As Long = -4 'Get/SetWindow offset to the WndProc procedure address
Private Const PATCH_04 As Long = 88 'Table B (before) address patch offset
Private Const PATCH_05 As Long = 93 'Table B (before) entry count patch offset
Private Const PATCH_08 As Long = 132 'Table A (after) address patch offset
Private Const PATCH_09 As Long = 137 'Table A (after) entry count patch offset
Private Type tSubData 'Subclass data type
hWnd As Long 'Handle of the window being subclassed
nAddrSub As Long 'The address of our new WndProc (allocated memory).
nAddrOrig As Long 'The address of the pre-existing WndProc
nMsgCntA As Long 'Msg after table entry count
nMsgCntB As Long 'Msg before table entry count
aMsgTblA() As Long 'Msg after table array
aMsgTblB() As Long 'Msg Before table array
End Type
Private sc_aSubData() As tSubData 'Subclass data array
Private sc_aBuf(1 To CODE_LEN) As Byte 'Code buffer byte array
Private sc_pCWP As Long 'Address of the CallWindowsProc
Private sc_pEbMode As Long 'Address of the EbMode IDE break/stop/running function
Private sc_pSWL As Long 'Address of the SetWindowsLong function
Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length 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 GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem 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 VirtualProtect Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function IsZoomed Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function BeginDeferWindowPos Lib "user32" (ByVal nNumWindows As Long) As Long
Private Declare Function DeferWindowPos Lib "user32" (ByVal hWinPosInfo As Long, 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 EndDeferWindowPos Lib "user32" (ByVal hWinPosInfo As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT2) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT2, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function UnionRect Lib "user32" (lpDestRect As RECT2, lpSrc1Rect As RECT2, lpSrc2Rect As RECT2) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal ByteLen As Long)
Public Sub zSubclass_Proc(ByVal bBefore As Boolean, ByRef bHandled As Boolean, ByRef lReturn As Long, ByRef lng_hWnd As Long, ByRef uMsg As Long, ByRef wParam As Long, ByRef lParam As Long)
Attribute zSubclass_Proc.VB_MemberFlags = "40"
'
'Parameters:
' bBefore - Indicates whether the the message is being processed before or after the default handler - only really needed if a message is set to callback both before & after.
' bHandled - Set this variable to True in a 'before' callback to prevent the message being subsequently processed by the default handler... and if set, an 'after' callback
' lReturn - Set this variable as per your intentions and requirements, see the MSDN documentation for each individual message value.
' lng_hWnd - The window handle
' uMsg - The message number
' wParam - Message related data
' lParam - Message related data
'
'Notes:
' If you really know what you're doing, it's possible to change the values of the
' hWnd, uMsg, wParam and lParam parameters in a 'before' callback so that different
' values get passed to the default handler.. and optionaly, the 'after' callback
Private Function Subclass_Start(ByVal lng_hWnd As Long) As Long
'Start subclassing the passed window handle
'Parameters:
' lng_hWnd - The handle of the window to be subclassed
'Returns;
' The sc_aSubData() index
Dim i As Long 'Loop index
Dim J As Long 'Loop index
Dim nSubIdx As Long 'Subclass data index
Dim sSubCode As String 'Subclass code string
Const GMEM_FIXED As Long = 0 'Fixed memory GlobalAlloc flag
Const PAGE_EXECUTE_READWRITE As Long = &H40& 'Allow memory to execute without violating XP SP2 Data Execution Prevention
Const PATCH_01 As Long = 18 'Code buffer offset to the location of the relative address to EbMode
Const PATCH_02 As Long = 68 'Address of the previous WndProc
Const PATCH_03 As Long = 78 'Relative address of SetWindowsLong
Const PATCH_06 As Long = 116 'Address of the previous WndProc
Const PATCH_07 As Long = 121 'Relative address of CallWindowProc
Const PATCH_0A As Long = 186 'Address of the owner object
Const FUNC_CWP As String = "CallWindowProcA" 'We use CallWindowProc to call the original WndProc
Const FUNC_EBM As String = "EbMode" 'VBA's EbMode function allows the machine code thunk to know if the IDE has stopped or is on a breakpoint
Const FUNC_SWL As String = "SetWindowLongA" 'SetWindowLongA allows the cSubclasser machine code thunk to unsubclass the subclasser itself if it detects via the EbMode function that the IDE has stopped
Const MOD_USER As String = "user32" 'Location of the SetWindowLongA & CallWindowProc functions
Const MOD_VBA5 As String = "vba5" 'Location of the EbMode function if running VB5
Const MOD_VBA6 As String = "vba6" 'Location of the EbMode function if running VB6
Call zPatchVal(VarPtr(sc_aBuf(1)), PATCH_0A, ObjPtr(Me)) 'Patch the address of this object instance into the static machine code buffer
sc_pCWP = zAddrFunc(MOD_USER, FUNC_CWP) 'Get the address of the CallWindowsProc function
sc_pSWL = zAddrFunc(MOD_USER, FUNC_SWL) 'Get the address of the SetWindowLongA function
ReDim sc_aSubData(0 To 0) As tSubData 'Create the first sc_aSubData element
Else
nSubIdx = zIdx(lng_hWnd, True)
If (nSubIdx = -1) Then 'If an sc_aSubData element isn't being re-cycled
nSubIdx = UBound(sc_aSubData()) + 1 'Calculate the next element
ReDim Preserve sc_aSubData(0 To nSubIdx) As tSubData 'Create a new sc_aSubData element
End If
Subclass_Start = nSubIdx
End If
With sc_aSubData(nSubIdx)
.nAddrSub = GlobalAlloc(GMEM_FIXED, CODE_LEN) 'Allocate memory for the machine code WndProc
Call VirtualProtect(ByVal .nAddrSub, CODE_LEN, PAGE_EXECUTE_READWRITE, i) 'Mark memory as executable
Call RtlMoveMemory(ByVal .nAddrSub, sc_aBuf(1), CODE_LEN) 'Copy the machine code from the static byte array to the code array in sc_aSubData
.hWnd = lng_hWnd 'Store the hWnd
.nAddrOrig = SetWindowLongA(.hWnd, GWL_WNDPROC, .nAddrSub) 'Set our WndProc in place
Call zPatchRel(.nAddrSub, PATCH_01, sc_pEbMode) 'Patch the relative address to the VBA EbMode api function, whether we need to not.. hardly worth testing
Call zPatchVal(.nAddrSub, PATCH_02, .nAddrOrig) 'Original WndProc address for CallWindowProc, call the original WndProc
Call zPatchRel(.nAddrSub, PATCH_03, sc_pSWL) 'Patch the relative address of the SetWindowLongA api function
Call zPatchVal(.nAddrSub, PATCH_06, .nAddrOrig) 'Original WndProc address for SetWindowLongA, unsubclass on IDE stop
Call zPatchRel(.nAddrSub, PATCH_07, sc_pCWP) 'Patch the relative address of the CallWindowProc api function
End With
End Function
Private Sub Subclass_StopAll()
'Stop all subclassing
Dim i As Long
i = UBound(sc_aSubData()) 'Get the upper bound of the subclass data array
Do While i >= 0 'Iterate through each element
With sc_aSubData(i)
If (.hWnd <> 0) Then 'If not previously Subclass_Stop'd
Call Subclass_Stop(.hWnd) 'Subclass_Stop
End If
End With
i = i - 1 'Next element
Loop
End Sub
Private Sub Subclass_Stop(ByVal lng_hWnd As Long)
'Stop subclassing the passed window handle
'Parameters:
' lng_hWnd - The handle of the window to stop being subclassed
With sc_aSubData(zIdx(lng_hWnd))
Call SetWindowLongA(.hWnd, GWL_WNDPROC, .nAddrOrig) 'Restore the original WndProc
Call zPatchVal(.nAddrSub, PATCH_05, 0) 'Patch the Table B entry count to ensure no further 'before' callbacks
Call zPatchVal(.nAddrSub, PATCH_09, 0) 'Patch the Table A entry count to ensure no further 'after' callbacks
Call GlobalFree(.nAddrSub) 'Release the machine code memory
.hWnd = 0 'Mark the sc_aSubData element as available for re-use
Debug.Assert zAddrFunc 'You may wish to comment out this line if you're using vb5 else the EbMode GetProcAddress will stop here everytime because we look for vba6.dll first
End Function
Private Sub zDelMsg(ByVal uMsg As Long, ByRef aMsgTbl() As Long, ByRef nMsgCnt As Long, ByVal When As eMsgWhen, ByVal nAddr As Long)
'Worker sub for Subclass_DelMsg
Dim nEntry As Long
If (uMsg = ALL_MESSAGES) Then 'If deleting all messages
nMsgCnt = 0 'Message count is now zero
If When = eMsgWhen.MSG_BEFORE Then 'If before
nEntry = PATCH_05 'Patch the before table message count location
Else 'Else after
nEntry = PATCH_09 'Patch the after table message count location
End If
Call zPatchVal(nAddr, nEntry, 0) 'Patch the table message count to zero
Else 'Else deleteting a specific message
Do While nEntry < nMsgCnt 'For each table entry
nEntry = nEntry + 1
If (aMsgTbl(nEntry) = uMsg) Then 'If this entry is the message we wish to delete
aMsgTbl(nEntry) = 0 'Mark the table slot as available
Exit Do 'Bail
End If
Loop 'Next entry
End If
End Sub
Private Function zIdx(ByVal lng_hWnd As Long, Optional ByVal bAdd As Boolean = False) As Long
'Get the sc_aSubData() array index of the passed hWnd
'Get the upper bound of sc_aSubData() - If you get an error here, you're probably Subclass_AddMsg-ing before Subclass_Start
zIdx = UBound(sc_aSubData)
Do While zIdx >= 0 'Iterate through the existing sc_aSubData() elements
With sc_aSubData(zIdx)
If (.hWnd = lng_hWnd) Then 'If the hWnd of this element is the one we're looking for
If (Not bAdd) Then 'If we're searching not adding
Exit Function 'Found
End If
ElseIf (.hWnd = 0) Then 'If this an element marked for reuse.
If (bAdd) Then 'If we're adding
Exit Function 'Re-use it
End If
End If
End With
zIdx = zIdx - 1 'Decrement the index
Loop
If (Not bAdd) Then
Debug.Assert False 'hWnd not found, programmer error
End If
'If we exit here, we're returning -1, no freed elements were found
End Function
Private Sub zPatchRel(ByVal nAddr As Long, ByVal nOffset As Long, ByVal nTargetAddr As Long)
'Patch the machine code buffer at the indicated offset with the relative address to the target address.
