I got this code off the Net from a project. The best I can make out it sets up some kind of a callback function but I'll be danged if I can figure it out.
Code:
Public Function sc_Subclass(ByVal lng_hWnd As Long, Optional ByVal lParamUser As Long = 0, Optional ByVal nOrdinal As Long = 1, Optional ByVal oCallback As Object = Nothing, Optional ByVal bIdeSafety As Boolean = True) As Boolean 'Subclass the specified window handle
'------------------------------------------------------------------------------------------------------------------------
' lng_hWnd - Handle of the window to subclass
' lParamUser - Optional, user-defined callback parameter
' nOrdinal - Optional, ordinal index of the callback procedure. 1 = last private method, 2 = second last private method, etc.
' oCallback - Optional, the object that will receive the callback. If undefined, callbacks are sent to this object's instance
' bIdeSafety - Optional, enable/disable IDE safety measures. NB: you should really only disable IDE safety in a UserControl for design-time subclassing
'------------------------------------------------------------------------------------------------------------------------
Const CODE_LEN As Long = 260 'Thunk length in bytes
Const MEM_LEN As Long = CODE_LEN + (8 * (MSG_ENTRIES + 1)) 'Bytes to allocate per thunk, data + code + msg tables
Const PAGE_RWX As Long = &H40& 'Allocate executable memory
Const MEM_COMMIT As Long = &H1000& 'Commit allocated memory
Const MEM_RELEASE As Long = &H8000& 'Release allocated memory flag
Const IDX_EBMODE As Long = 3 'Thunk data index of the EbMode function address
Const IDX_CWP As Long = 4 'Thunk data index of the CallWindowProc function address
Const IDX_SWL As Long = 5 'Thunk data index of the SetWindowsLong function address
Const IDX_FREE As Long = 6 'Thunk data index of the VirtualFree function address
Const IDX_BADPTR As Long = 7 'Thunk data index of the IsBadCodePtr function address
Const IDX_OWNER As Long = 8 'Thunk data index of the Owner object's vTable address
Const IDX_CALLBACK As Long = 10 'Thunk data index of the callback method address
Const IDX_EBX As Long = 16 'Thunk code patch index of the thunk data
Const SUB_NAME As String = "sc_Subclass" 'This routine's name
Dim nAddr As Long
Dim nID As Long
Dim nMyID As Long
If IsWindow(lng_hWnd) = 0 Then 'Ensure the window handle is valid
zError SUB_NAME, "Invalid window handle"
Exit Function
End If
nMyID = GetCurrentProcessId 'Get this process's ID
GetWindowThreadProcessId lng_hWnd, nID 'Get the process ID associated with the window handle
If nID <> nMyID Then 'Ensure that the window handle doesn't belong to another process
zError SUB_NAME, "Window handle belongs to another process"
Exit Function
End If
If oCallback Is Nothing Then 'If the user hasn't specified the callback owner
Set oCallback = Form1 'Then it is me
End If
'App will crash if oCallback not initialized
nAddr = zAddressOf(oCallback, nOrdinal) 'Get the address of the specified ordinal method
If nAddr = 0 Then 'Ensure that we've found the ordinal method
zError SUB_NAME, "Callback method not found"
Exit Function
End If
If z_Funk Is Nothing Then 'If this is the first time through, do the one-time initialization
Set z_Funk = New Collection 'Create the hWnd/thunk-address collection
z_Sc(14) = &HD231C031: z_Sc(15) = &HBBE58960: z_Sc(17) = &H4339F631: '--> more of the same
z_Sc(40) = &H6A2473FF: z_Sc(41) = &H873FFFC: z_Sc(42) = &H891453FF: '--> more of the same
z_Sc(IDX_CWP) = zFnAddr("user32", "CallWindowProcA") 'Store CallWindowProc function address in the thunk data
z_Sc(IDX_SWL) = zFnAddr("user32", "SetWindowLongA") 'Store the SetWindowLong function address in the thunk data
z_Sc(IDX_FREE) = zFnAddr("kernel32", "VirtualFree") 'Store the VirtualFree function address in the thunk data
z_Sc(IDX_BADPTR) = zFnAddr("kernel32", "IsBadCodePtr") 'Store the IsBadCodePtr function address in the thunk data
End If
z_ScMem = VirtualAlloc(0, MEM_LEN, MEM_COMMIT, PAGE_RWX) 'Allocate executable memory
If z_ScMem <> 0 Then 'Ensure the allocation succeeded
On Error GoTo CatchDoubleSub 'Catch double subclassing
z_Funk.Add z_ScMem, "h" & lng_hWnd 'Add the hWnd/thunk-address to the collection
On Error GoTo 0
If bIdeSafety Then 'If the user wants IDE protection
z_Sc(IDX_EBMODE) = zFnAddr("vba6", "EbMode") 'Store the EbMode function address in the thunk data
End If
z_Sc(IDX_EBX) = z_ScMem 'Patch the thunk data address
z_Sc(IDX_HWND) = lng_hWnd 'Store the window handle in the thunk data
z_Sc(IDX_BTABLE) = z_ScMem + CODE_LEN 'Store the address of the before table in the thunk data
z_Sc(IDX_ATABLE) = z_ScMem + CODE_LEN + ((MSG_ENTRIES + 1) * 4) 'Store the address of the after table in the thunk data
z_Sc(IDX_OWNER) = ObjPtr(oCallback) 'Store the callback owner's object address in the thunk data
z_Sc(IDX_CALLBACK) = nAddr 'Store the callback address in the thunk data
z_Sc(IDX_PARM_USER) = lParamUser 'Store the lParamUser callback parameter in the thunk data
nAddr = SetWindowLong(lng_hWnd, GWL_WNDPROC, z_ScMem + WNDPROC_OFF) 'Set the new WndProc, return the address of the original WndProc
If nAddr = 0 Then 'Ensure the new WndProc was set correctly
zError SUB_NAME, "SetWindowLong failed, error #" & Err.LastDllError
GoTo ReleaseMemory
End If
z_Sc(IDX_WNDPROC) = nAddr 'Store the original WndProc address in the thunk data
'RtlMoveMemory z_ScMem, VarPtr(z_Sc(0)), CODE_LEN 'Copy the thunk code/data to the allocated memory
CpyMem ByVal z_ScMem, z_Sc(0), CODE_LEN
sc_Subclass = True 'Indicate success
Else
zError SUB_NAME, "VirtualAlloc failed, error: " & Err.LastDllError
End If
Exit Function 'Exit sc_Subclass
CatchDoubleSub:
zError SUB_NAME, "Window handle is already subclassed"
ReleaseMemory:
VirtualFree z_ScMem, 0, MEM_RELEASE 'sc_Subclass has failed after memory allocation, so release the memory
End Function
Public Sub sc_UnSubclass(ByVal lng_hWnd As Long)
If z_Funk Is Nothing Then 'Ensure that subclassing has been started
zError "sc_UnSubclass", "Window handle isn't subclassed"
Else
If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then 'Ensure that the thunk hasn't already released its memory
zData(IDX_SHUTDOWN) = -1 'Set the shutdown indicator
zDelMsg ALL_MESSAGES, IDX_BTABLE 'Delete all before messages
zDelMsg ALL_MESSAGES, IDX_ATABLE 'Delete all after messages
End If
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
Public Sub sc_AddMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = eMsgWhen.MSG_AFTER)
If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then 'Ensure that the thunk hasn't already released its memory
If When And MSG_BEFORE Then 'If the message is to be added to the before original WndProc table...
zAddMsg 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 uMsg, IDX_ATABLE 'Add the message to the after table
End If
End If
End Sub
Private Sub zAddMsg(ByVal uMsg As Long, ByVal nTable As Long)
Dim nCount As Long 'Table entry count
Dim nBase As Long 'Remember z_ScMem
Dim i As Long 'Loop index
nBase = z_ScMem 'Remember z_ScMem so that we can restore its value on exit
z_ScMem = zData(nTable) 'Map zData() to the specified table
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"
GoTo Bail
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
GoTo Bail 'Bail
ElseIf zData(i) = uMsg Then 'If the message is already in the table...
GoTo Bail '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
Bail:
z_ScMem = nBase 'Restore the value of z_ScMem
End Sub
'Delete the message from the specified table of the window handle
Private Sub zDelMsg(ByVal uMsg As Long, ByVal nTable As Long)
Dim nCount As Long 'Table entry count
Dim nBase As Long 'Remember z_ScMem
Dim i As Long 'Loop index
nBase = z_ScMem 'Remember z_ScMem so that we can restore its value on exit
z_ScMem = zData(nTable) 'Map zData() to the specified table
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
GoTo Bail 'Bail
End If
Next i 'Next message table entry
zError "zDelMsg", "Message &H" & Hex$(uMsg) & " not found in table"
End If
Bail:
z_ScMem = nBase 'Restore the value of z_ScMem
End Sub
'Error handler
Private Sub zError(ByVal sRoutine As String, ByVal sMsg As String)
App.LogEvent TypeName(Form1) & "." & sRoutine & ": " & sMsg, vbLogEventTypeError
MsgBox sMsg & ".", vbExclamation + vbApplicationModal, "Error in " & TypeName(Form1) & "." & sRoutine
End Sub