API CallBacks Using an Object's Procedure

[xiaoyao]

MsgBox ListVb6ComFunction(ObjPtr(Me))
ListVb6ComFunction(ObjPtr(Me), False, False) 'show all only in vb6 ide

Public Type FunctionInfo
    MethodName As String
    ArgCount As Long
    VtableOffset As Long
    IsFunction As Boolean
    MethodType As String
End Type
Public FunList() As FunctionInfo
 
 Public Function ListVb6ComFunction(ByVal ObjPtrV As Long, Optional OnlyMethod As Boolean = True, Optional PublicItem As Boolean = True) As Long
 Dim MethodTypeArr(3) As String
 MethodTypeArr(0) = "Method"
 MethodTypeArr(1) = "Get"
 MethodTypeArr(2) = "Let"
 MethodTypeArr(3) = "Set"
 
 ReDim FunList(0)
 Dim sMethodName As String, lArgCount As Long, ID As Long
 ID = -1
   If Not ObjectIsVb6ComCodeModule_P(ObjPtrV) Then Exit Function                           ' Make sure we're dealing with a VB6 COM-code object.
   
    '
    Dim pVTbl       As Long:    GetMem4 ByVal ObjPtrV, pVTbl                      ' Pointer to vTable.
    Dim pObjInfo    As Long:    GetMem4 ByVal pVTbl - 4&, pObjInfo                  ' Pointer to tObjectInfo structure.
    Dim pPubDesc    As Long:    GetMem4 ByVal pObjInfo + &H18&, pPubDesc            ' tObjectInfo.aObject which points to tObject structure.
    Dim pPrivDesc   As Long:    GetMem4 ByVal pObjInfo + &HC&, pPrivDesc            ' tObjectInfo.lpPrivateObject which points to tPrivateObj structure.
    '
    If pPrivDesc = 0& Then Exit Function                                            ' Just a double-check.
    '
    Dim lIndex      As Long
    Dim pName       As Long
    '
    ' Search the procedures within the module.
    Dim pMethDesc   As Long
    Dim iMethOffset As Integer
    Dim bbArgs      As Byte
    Dim lMethodsCnt As Long:    GetMem2 ByVal pPubDesc + &H1C&, lMethodsCnt         ' tObject.ProcCount value.
    Dim pNames      As Long:    GetMem4 ByVal pPubDesc + &H20&, pNames              ' tObject.aProcNamesArray which points to an array of name pointers.
    Dim pMethodsPtr As Long:    GetMem4 ByVal pPrivDesc + &H18&, pMethodsPtr        ' tPrivateObj.lpFuncTypeInfo which points to an array of pointers.
    Dim NewFunName As String
    ' Loop through methods and see if we can find the one we want.
    For lIndex = 0& To lMethodsCnt - 1&
        GetMem4 ByVal pMethodsPtr + lIndex * 4&, pMethDesc                          ' From the array, getting a pointer to a method structure (tMethInfo).
        If pMethDesc Then                                                           ' Not sure if this ever returns zero, maybe for "Private" methods?
            GetMem2 ByVal pMethDesc + 2&, iMethOffset                               ' Out of tMethInfo structure.
            GetMem1 ByVal pMethDesc, bbArgs                                         ' First two bits of bbArgs are: set=3, get=1, let=2, method=0 (Sub or Fn).
             If OnlyMethod = False Or (bbArgs And CByte(3)) = CByte(0) Then 'if 2                         ' Make sure it's a method.
                
                If PublicItem = False Or iMethOffset And 1 Then                                           ' First bit, 1=Public.
                    GetMem4 ByVal pNames + lIndex * 4&, pName                       ' Dig pointer to method name from array of name pointers.
                    ID = ID + 1
                    ReDim Preserve FunList(ID) 'new item>>>>
                    NewFunName = SysAllocStringByteLen(ByVal pName, lstrlenA(ByVal pName))
                    FunList(ID).MethodName = NewFunName
                    FunList(ID).MethodType = MethodTypeArr(bbArgs And CByte(3))
                    
                    Form1.List1.AddItem NewFunName
                    
                    
                        FunList(ID).VtableOffset = CLng(iMethOffset And &HFFFC)  ' First two bits are something else (first is Public=1,Private=0).
                        Dim bbFlags As Byte: GetMem1 ByVal pMethDesc + 1&, bbFlags  ' Both bbArgs & bbFlags out of tMethInfo structure.
                        bbFlags = bbFlags And CByte(1)                              ' 0 (no return), 1 (return).
                        FunList(ID).IsFunction = bbFlags
                        lArgCount = CLng(bbArgs \ CByte(4) - bbFlags)               ' Calculate arguments, excluding any return argument.  Tested for vbGet, vbLet, vbSet, vbMethod (both Function & Sub).
                        FunList(ID).ArgCount = lArgCount
                         
                        Debug.Print lIndex + 1 & ">ID=" & ID & " " & IIf(FunList(ID).IsFunction, "Function ", "Sub ") & NewFunName & "(" & IIf(FunList(ID).ArgCount > 0, "Args=" & lArgCount, "") & ")--" & FunList(ID).MethodType
                End If
            End If 'if 2 end
        End If
    Next
   ListVb6ComFunction = ID
End Function