AddressOf for Class Methods (and other VTable exploration)?

[Victor Bravo VI]

Here are some routines that addresses the question "Is there an AddressOf for object modules?" These functions are heavily based on Paul Caton's code here and LaVolpe's code here. These have not been tested in VBA, so use at your own risk.

Option Explicit

Private Declare Function GetMem1 Lib "msvbvm60.dll" (ByVal Addr As Long, ByRef RetVal As Byte) As Long
Private Declare Function GetMem4 Lib "msvbvm60.dll" (ByVal Addr As Long, ByRef RetVal As Long) As Long
Private Declare Function IsBadCodePtr Lib "kernel32.dll" (ByVal lpfn As Long) As Long

'Returns the procedure address of the first Public member (in declared order)
'or the first Private/Friend member (in declared order) if there's no Public member
'Public variables (which actually are Public Properties) are skipped

Public Function AddressOfFirstProc(ByVal pObj As Long) As Long
    Const NATIVE_CODE As Byte = &HE9, PCODE As Byte = &H33
    Dim JumpOpcode As Byte, pEntry As Long, pVTable As Long

    GetMem4 pObj, pVTable

    Do: GetMem4 pVTable, pEntry

        If IsBadCodePtr(pEntry) = 0& Then
            GetMem1 pEntry, JumpOpcode

            Select Case JumpOpcode
                Case NATIVE_CODE, PCODE
                    AddressOfFirstProc = pEntry
                    Exit Function
            End Select

            pVTable = UAdd(pVTable, 4&)
        Else
            Exit Function
        End If
    Loop
End Function

'Returns the procedure address of the last Private/Friend member (in declared order)
'or the last Public member (in declared order) if there's no Private/Friend member
'Public variables (which actually are Public Properties) are skipped

Public Function AddressOfLastProc(ByVal pObj As Long) As Long
    Dim JumpOpcode As Byte, JumpOpcode1st As Byte
    Dim VTOffset As Long, pEntry As Long, pVTable As Long

    GetMem4 pObj, pVTable                   'Get address of the object's VTable
    VTOffset = OffsetOfFirstProc(pObj)

    If VTOffset Then
        pVTable = UAdd(pVTable, VTOffset)   'Bump to the user part of the object's VTable [Typically, &H1C for Classes, &H6F8 for Forms & &H7A4 for UCs]
        GetMem4 pVTable, pEntry             'Read the address of the first entry point
        GetMem1 pEntry, JumpOpcode1st       'Read the jump opcode at the first entry point [&H33 for pseudo code, &HE9 for native code]
        AddressOfLastProc = pEntry
    Else
        Exit Function
    End If

    Do: pVTable = UAdd(pVTable, 4&)         'Next entry address
        GetMem4 pVTable, pEntry             'Read the address of the entry point

        If IsBadCodePtr(pEntry) = 0& Then   'Is the entry point address valid code?
            GetMem1 pEntry, JumpOpcode      'Read the jump opcode at the entry point
        Else
            Exit Function
        End If

        If JumpOpcode = JumpOpcode1st Then  'Does the jump opcode match that of the first VTable entry?
            AddressOfLastProc = pEntry
        Else
            Exit Function
        End If
    Loop
End Function

'Returns the procedure address of the specified Public or Private member
'The Ordinal argument is the 1-based order of the member. For example:
'The 1st Public member (or Private member if there are no Public members)
'in the declared source code order has an ordinal of 1. The 2nd Public member
'(or Private member if there are no Public members) has an ordinal of 2. And so on...
'Public members are counted first before Private/Friend members. If member(s) have
'been added/removed/rearranged, recalculate the Ordinal to make sure it is correct.

Public Function AddressOfMember(ByVal pObj As Long, ByVal Ordinal As Long) As Long
    Const NATIVE_CODE As Byte = &HE9, PCODE As Byte = &H33
    Dim JumpOpcode As Byte, Index As Long, pEntry As Long, pVTable As Long

    If Ordinal > 0& Then GetMem4 pObj, pVTable Else Exit Function

    Do: GetMem4 pVTable, pEntry

        If IsBadCodePtr(pEntry) = 0& Then
            GetMem1 pEntry, JumpOpcode

            Select Case JumpOpcode
                Case NATIVE_CODE, PCODE
                    Index = Index + 1&

                    If Index = Ordinal Then
                        AddressOfMember = pEntry
                        Exit Function
                    End If
            End Select

            pVTable = UAdd(pVTable, 4&)
        Else
            Exit Function
        End If
    Loop
End Function

'Returns the VTable offset (in Bytes) of the first Public member (in declared order)
'or the first Private/Friend member (in declared order) if there's no Public member
'Public variables (which actually are Public Properties) are skipped

Public Function OffsetOfFirstProc(ByVal pObj As Long) As Long
    Const NATIVE_CODE As Byte = &HE9, PCODE As Byte = &H33
    Dim JumpOpcode As Byte, pEntry As Long, pStart As Long, pVTable As Long

    GetMem4 pObj, pStart
    pVTable = pStart

    Do: GetMem4 pVTable, pEntry

        If IsBadCodePtr(pEntry) = 0& Then
            GetMem1 pEntry, JumpOpcode

            Select Case JumpOpcode
                Case NATIVE_CODE, PCODE
                    OffsetOfFirstProc = UAdd(pVTable, -pStart)
                    Exit Function
            End Select

            pVTable = UAdd(pVTable, 4&)
        Else
            Exit Function
        End If
    Loop
End Function

'Returns the VTable offset (in Bytes) of the last Private/Friend member (in declared order)
'or the last Public member (in declared order) if there's no Private/Friend member
'Public variables (which actually are Public Properties) are skipped

Public Function OffsetOfLastProc(ByVal pObj As Long) As Long
    Dim JumpOpcode As Byte, JumpOpcode1st As Byte, VTOffset As Long
    Dim pEntry As Long, pStart As Long, pVTable As Long

    GetMem4 pObj, pStart
    VTOffset = OffsetOfFirstProc(pObj)

    If VTOffset Then
        pVTable = UAdd(pStart, VTOffset)
        GetMem4 pVTable, pEntry
        GetMem1 pEntry, JumpOpcode1st
        OffsetOfLastProc = VTOffset
    Else
        Exit Function
    End If

    Do: pVTable = UAdd(pVTable, 4&)
        GetMem4 pVTable, pEntry

        If IsBadCodePtr(pEntry) = 0& Then
            GetMem1 pEntry, JumpOpcode
        Else
            Exit Function
        End If

        If JumpOpcode = JumpOpcode1st Then
            OffsetOfLastProc = UAdd(pVTable, -pStart)
        Else
            Exit Function
        End If
    Loop
End Function

Private Function UAdd(ByVal Base As Long, ByVal Offset As Long) As Long
    Const SIGN_BIT = &H80000000

    UAdd = (Base Xor SIGN_BIT) + Offset Xor SIGN_BIT 'Unsigned pointer arithmetic
End Function