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

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

---

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

Code:

---

'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

---

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.

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.

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.

Quote:

---

Originally Posted by Bonnie West

....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.

Quote:

---

Originally Posted by Niya

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

---

You are right, of course! :thumb: