Anyone know what this code is, what it does, and how it works

[jmsrickland]

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.

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

[jmsrickland]

This code is continued from 1st post as it was too long

'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 "zMap_hWnd", "Subclassing hasn't been started"
 Else
   On Error GoTo Catch                                                     'Catch unsubclassed window handles
   z_ScMem = z_Funk("h" & lng_hWnd)                                        'Get the thunk address
   zMap_hWnd = z_ScMem
 End If
  
 Exit Function                                                             'Exit returning the thunk address

Catch:
 zError "zMap_hWnd", "Window handle isn't subclassed"
End Function

Return the address of the specified ordinal method on the oCallback object, 1 = last private method, 2 = second last private method, etc
Private Function zAddressOf(ByVal oCallback As Object, ByVal nOrdinal As Long) As Long
 Dim bSub As Byte                                                           'Value we expect to find pointed at by a vTable method entry
 Dim bVal As Byte
 Dim nAddr As Long                                                          'Address of the vTable
 Dim i As Long                                                              'Loop index
 Dim j As Long                                                              'Loop limit
  
 'RtlMoveMemory VarPtr(nAddr), ObjPtr(oCallback), 4                         'Get the address of the callback object's instance
 CpyMem nAddr, ByVal ObjPtr(oCallback), 4

 If Not zProbe(nAddr + &H1C, i, bSub) Then                                 'Probe for a Class method
   If Not zProbe(nAddr + &H6F8, i, bSub) Then                              'Probe for a Form method
     If Not zProbe(nAddr + &H7A4, i, bSub) Then                            'Probe for a UserControl method
       Exit Function                                                       'Bail...
      End If
    End If
  End If
  
 i = i + 4                                                                 'Bump to the next entry
 j = i + 1024                                                              'Set a reasonable limit, scan 256 vTable entries
    
 Do While i < j
   'RtlMoveMemory VarPtr(nAddr), i, 4                                       'Get the address stored in this vTable entry
   CpyMem nAddr, ByVal i, 4
    
   If IsBadCodePtr(nAddr) Then                                             'Is the entry an invalid code address?
     'RtlMoveMemory VarPtr(zAddressOf), i - (nOrdinal * 4), 4               'Return the specified vTable entry address
      CpyMem zAddressOf, ByVal (i - (nOrdinal * 4)), 4
      Exit Do                                                               'Bad method signature, quit loop
    End If

    'RtlMoveMemory VarPtr(bVal), nAddr, 1                                    'Get the byte pointed to by the vTable entry
    CpyMem bVal, ByVal nAddr, 1
    
    If bVal <> bSub Then                                                    'If the byte doesn't match the expected value...
      'RtlMoveMemory VarPtr(zAddressOf), i - (nOrdinal * 4), 4               'Return the specified vTable entry address
       CpyMem zAddressOf, ByVal (i - (nOrdinal * 4)), 4
       Exit Do                                                               'Bad method signature, quit loop
    End If
 
    i = i + 4                                                             'Next vTable entry
  Loop
End Function

'Probe at the specified start address for a method signature
Private Function zProbe(ByVal nStart As Long, ByRef nMethod As Long, ByRef bSub As Byte) As Boolean
 Dim bVal As Byte
 Dim nAddr As Long
 Dim nLimit As Long
 Dim nEntry As Long
  
 nAddr = nStart                                                            'Start address
 nLimit = nAddr + 32                                                       'Probe eight entries
    
 Do While nAddr < nLimit                                                   'While we've not reached our probe depth
   'RtlMoveMemory VarPtr(nEntry), nAddr, 4                                  'Get the vTable entry
   CpyMem nEntry, ByVal nAddr, 4
    
   If nEntry <> 0 Then                                                     'If not an implemented interface
     'RtlMoveMemory VarPtr(bVal), nEntry, 1                                 'Get the value pointed at by the vTable entry
     CpyMem bVal, ByVal nEntry, 1
            
     If bVal = &H33 Or bVal = &HE9 Then                                    'Check for a native or pcode method signature
       nMethod = nAddr                                                     'Store the vTable entry
       bSub = bVal                                                         'Store the found method signature
       zProbe = True                                                       'Indicate success
       Exit Function                                                       'Return
     End If
   End If
    
   nAddr = nAddr + 4                                                       'Next vTable entry
 Loop
End Function

Private Property Get zData(ByVal nIndex As Long) As Long
 CpyMem zData, ByVal z_ScMem + (nIndex * 4), 4
End Property

Private Property Let zData(ByVal nIndex As Long, ByVal nValue As Long)
 CpyMem ByVal z_ScMem + (nIndex * 4), nValue, 4
End Property

[Bonnie West]

It's a self-subclass code, most likely by Paul Caton. It enables placing the subclassing procedure right inside the object module (Form, Class, UserControl, etc.) without the need for a static module (*.BAS). Thus, it makes the object module fully self-contained. It uses a dynamically-allocated ASM code that redirects the subclass callback to the appropriate procedure inside the object module.

If you would prefer to use a much simpler self-subclass code, try the revised code by Paul Caton (which is more comprehensible IMHO). See it in action here.

[jmsrickland]

Seems like a lot of convoluted code just to get a callback. It's in a project I got off the net and it was originally placed in a class module but I didn't want any class modules so I placed it in a BAS module and I placed the callback procedure in a Form module and it is the last Private procedure it works. I just couldn't figure out all it was doing. It is quite difficult to follow when all I want is a callback. Why is this any better than just placing a callback as normal in a .BAS module which is much easier to read and understand.

As far as your link to the simpler version I wouldn't know how to employ it with the project I'm working on. The code I posted works and even though I don't have the slightest clue how it works at least I got it to work with my project.

[Bonnie West]

I can think of two reasons why such code came into existence. It could be because someone wanted to get past the limitations of the AddressOf operator and also, as I've mentioned previously, to make an object module completely self-contained. I believe self-contained modules, especially UserControl modules, make them very easy to include in a project, since there is only 1 file.

[Niya]

....I've mentioned previously, to make an object module completely self-contained. I believe self-contained modules, especially UserControl modules, make them very easy to include in a project, since there is only 1 file.

There may be a bigger advantage than that....Multiple instances. A module is single instance and shared with all instances of all classes in the application but if you can put the subclassed procedures inside the UserControl, you can use instance specific data easily from the subclassed procedure.

[Bonnie West]

There may be a bigger advantage than that....Multiple instances...

You are right, of course!