Get list of all Properties and Methods for an object with VBA code alone

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,797
Office Version
  1. 2016
Platform
  1. Windows
Hi dear forum,

Workbook Sample

I am posting here a self-contained vba approach for getting members of an object without the need for an external dll such as the well known TLBNINF32.DLL .

The GetObjectFunctions function takes two arguments : (1) The object being browsed and (2) an optional arg specifying the function type being requested ie: Method, Property Let, Property Get etc...

The GetObjectFunctions function returns only function names and types. It doesn't provide other info such as function arguments or return types etc.

Tested on 32-bit and 64Bit.



1- API based code in a Standard Module:
VBA Code:
Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type TTYPEDESC
    #If Win64 Then
        pTypeDesc As LongLong
    #Else
        pTypeDesc As Long
    #End If
    vt            As Integer
End Type

Private Type TPARAMDESC
    #If Win64 Then
        pPARAMDESCEX  As LongLong
    #Else
        pPARAMDESCEX  As Long
    #End If
    wParamFlags       As Integer
End Type

Private Type TELEMDESC
    tdesc  As TTYPEDESC
    pdesc  As TPARAMDESC
End Type

Type TYPEATTR
        aGUID As GUID
        LCID As Long
        dwReserved As Long
        memidConstructor As Long
        memidDestructor As Long
        #If Win64 Then
            lpstrSchema As LongLong
        #Else
            lpstrSchema As Long
        #End If
        cbSizeInstance As Integer
        typekind As Long
        cFuncs As Integer
        cVars As Integer
        cImplTypes As Integer
        cbSizeVft As Integer
        cbAlignment As Integer
        wTypeFlags As Integer
        wMajorVerNum As Integer
        wMinorVerNum As Integer
        tdescAlias As Long
        idldescType As Long
End Type


Type FUNCDESC
    memid As Long
    #If Win64 Then
        lReserved1 As LongLong
        lprgelemdescParam As LongLong
    #Else
        lReserved1 As Long
        lprgelemdescParam As Long
    #End If
    funckind As Long
    INVOKEKIND As Long
    CallConv As Long
    cParams As Integer
    cParamsOpt As Integer
    oVft As Integer
    cReserved2 As Integer
    elemdescFunc As TELEMDESC
    wFuncFlags As Integer
End Type

#If VBA7 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare PtrSafe Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
#Else
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As Long, ByVal offsetinVft As Long, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As Long, ByRef retVAR As Variant) As Long
    Private Declare Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
#End If




Function GetObjectFunctions(ByVal TheObject As Object, Optional ByVal FuncType As VbCallType) As Collection


    Dim tTYPEATTR As TYPEATTR
    Dim tFUNCDESC As FUNCDESC

    Dim aGUID(0 To 11) As Long, lFuncsCount As Long
    
    #If Win64 Then
        Const vTblOffsetFac_32_64 = 2
        Dim aTYPEATTR() As LongLong, aFUNCDESC() As LongLong, farPtr As LongLong
    #Else
        Const vTblOffsetFac_32_64 = 1
        Dim aTYPEATTR() As Long, aFUNCDESC() As Long, farPtr As Long
    #End If
    
    Dim ITypeInfo As IUnknown
    Dim IDispatch As IUnknown
    Dim sName As String, oCol As New Collection
    
    Const CC_STDCALL As Long = 4
    Const IUNK_QueryInterface As Long = 0
    Const IDSP_GetTypeInfo As Long = 16 * vTblOffsetFac_32_64
    Const ITYP_GetTypeAttr As Long = 12 * vTblOffsetFac_32_64
    Const ITYP_GetFuncDesc As Long = 20 * vTblOffsetFac_32_64
    Const ITYP_GetDocument As Long = 48 * vTblOffsetFac_32_64

    Const ITYP_ReleaseTypeAttr As Long = 76 * vTblOffsetFac_32_64
    Const ITYP_ReleaseFuncDesc As Long = 80 * vTblOffsetFac_32_64


    aGUID(0) = &H20400: aGUID(2) = &HC0&: aGUID(3) = &H46000000
    CallFunction_COM ObjPtr(TheObject), IUNK_QueryInterface, vbLong, CC_STDCALL, VarPtr(aGUID(0)), VarPtr(IDispatch)
    If IDispatch Is Nothing Then MsgBox "error":   Exit Function

    CallFunction_COM ObjPtr(IDispatch), IDSP_GetTypeInfo, vbLong, CC_STDCALL, 0&, 0&, VarPtr(ITypeInfo)
    If ITypeInfo Is Nothing Then MsgBox "error": Exit Function
    
    CallFunction_COM ObjPtr(ITypeInfo), ITYP_GetTypeAttr, vbLong, CC_STDCALL, VarPtr(farPtr)
    If farPtr = 0& Then MsgBox "error": Exit Function

    CopyMemory ByVal VarPtr(tTYPEATTR), ByVal farPtr, LenB(tTYPEATTR)
    ReDim aTYPEATTR(LenB(tTYPEATTR))
    CopyMemory ByVal VarPtr(aTYPEATTR(0)), tTYPEATTR, UBound(aTYPEATTR)
    CallFunction_COM ObjPtr(ITypeInfo), ITYP_ReleaseTypeAttr, vbEmpty, CC_STDCALL, farPtr
    
    For lFuncsCount = 0 To tTYPEATTR.cFuncs - 1
        Call CallFunction_COM(ObjPtr(ITypeInfo), ITYP_GetFuncDesc, vbLong, CC_STDCALL, lFuncsCount, VarPtr(farPtr))
        If farPtr = 0 Then MsgBox "error": Exit For
        CopyMemory ByVal VarPtr(tFUNCDESC), ByVal farPtr, LenB(tFUNCDESC)
        ReDim aFUNCDESC(LenB(tFUNCDESC))
        CopyMemory ByVal VarPtr(aFUNCDESC(0)), tFUNCDESC, UBound(aFUNCDESC)
        Call CallFunction_COM(ObjPtr(ITypeInfo), ITYP_ReleaseFuncDesc, vbEmpty, CC_STDCALL, farPtr)
         Call CallFunction_COM(ObjPtr(ITypeInfo), ITYP_GetDocument, vbLong, CC_STDCALL, aFUNCDESC(0), VarPtr(sName), 0, 0, 0)
        Call CallFunction_COM(ObjPtr(ITypeInfo), ITYP_GetDocument, vbLong, CC_STDCALL, aFUNCDESC(0), VarPtr(sName), 0, 0, 0)

        With tFUNCDESC
            If FuncType Then
                If .INVOKEKIND = FuncType Then
                    'Debug.Print sName & vbTab & Switch(.INVOKEKIND = 1, "VbMethod", .INVOKEKIND = 2, "VbGet", .INVOKEKIND = 4, "VbLet", .INVOKEKIND = 8, "VbSet")
                    oCol.Add sName & vbTab & Switch(.INVOKEKIND = 1, "VbMethod", .INVOKEKIND = 2, "VbGet", .INVOKEKIND = 4, "VbLet", .INVOKEKIND = 8, "VbSet")
                End If
            Else
                'Debug.Print sName & vbTab & Switch(.INVOKEKIND = 1, "VbMethod", .INVOKEKIND = 2, "VbGet", .INVOKEKIND = 4, "VbLet", .INVOKEKIND = 8, "VbSet")
                oCol.Add sName & vbTab & Switch(.INVOKEKIND = 1, "VbMethod", .INVOKEKIND = 2, "VbGet", .INVOKEKIND = 4, "VbLet", .INVOKEKIND = 8, "VbSet")
            End If
        End With
        sName = vbNullString
    Next
    
    Set GetObjectFunctions = oCol

End Function



#If Win64 Then
    Private Function CallFunction_COM(ByVal InterfacePointer As LongLong, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant

    Dim vParamPtr() As LongLong
#Else
    Private Function CallFunction_COM(ByVal InterfacePointer As Long, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant

    Dim vParamPtr() As Long
#End If

    If InterfacePointer = 0& Or VTableOffset < 0& Then Exit Function
    If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function

    Dim pIndex As Long, pCount As Long
    Dim vParamType() As Integer
    Dim vRtn As Variant, vParams() As Variant

    vParams() = FunctionParameters()
    pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    If pCount = 0& Then
        ReDim vParamPtr(0 To 0)
        ReDim vParamType(0 To 0)
    Else
        ReDim vParamPtr(0 To pCount - 1&)
        ReDim vParamType(0 To pCount - 1&)
        For pIndex = 0& To pCount - 1&
            vParamPtr(pIndex) = VarPtr(vParams(pIndex))
            vParamType(pIndex) = VarType(vParams(pIndex))
        Next
    End If

    pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, pCount, _
    vParamType(0), vParamPtr(0), vRtn)
    If pIndex = 0& Then
        CallFunction_COM = vRtn
    Else
        SetLastError pIndex
    End If

End Function


2- Function Usage:
VBA Code:
    'Example:
    ' List all Methods and Properties of the excel application Object.
Public Sub Test()

    Dim oFuncCol As New Collection, i As Long, oObject As Object, sObjName As String

    
    Set oObject = Application '<=== Choose here target object as required.
    Set oFuncCol = GetObjectFunctions(TheObject:=oObject, FuncType:=0)
    
    Cells.CurrentRegion.Offset(1).ClearContents
    For i = 1 To oFuncCol.Count
        Range("A" & i + 1) = Split(oFuncCol.Item(i), vbTab)(0): Range("B" & i + 1) = Split(oFuncCol.Item(i), vbTab)(1)
    Next
    Range("C2") = oFuncCol.Count
    Cells(1).Resize(, 2).EntireColumn.AutoFit
    
    On Error Resume Next
        sObjName = oObject.Name
        If Len(sObjName) Then
            MsgBox "(" & oFuncCol.Count & ")  functions found for:" & vbCrLf & vbCrLf & sObjName
        End If
    On Error GoTo 0
    
End Sub

Regards.
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
This is an update of the previous code .

This update will provide more info on the browsed object.. Info such as the function vTable offset, member ID, Parameters count and the function return Type.

It should also work for browsing the Properties and Methods of user custom Classes (the demo workbook contains a class for testing)

File demo: ITypeInfo2.xls



1- API code in a Standard Module:
VBA Code:
Option Explicit

Private Enum VarEnum
    VT_EMPTY = 0&                   '
    VT_NULL = 1&                    ' 0
    VT_I2 = 2&                      ' signed 2 bytes integer
    VT_I4 = 3&                      ' signed 4 bytes integer
    VT_R4 = 4&                      ' 4 bytes float
    VT_R8 = 5&                      ' 8 bytes float
    VT_CY = 6&                      ' currency
    VT_DATE = 7&                    ' date
    VT_BSTR = 8&                    ' BStr
    VT_DISPATCH = 9&                ' IDispatch
    VT_ERROR = 10&                  ' error value
    VT_BOOL = 11&                   ' boolean
    VT_VARIANT = 12&                ' variant
    VT_UNKNOWN = 13&                ' IUnknown
    VT_DECIMAL = 14&                ' decimal
    VT_I1 = 16&                     ' signed byte
    VT_UI1 = 17&                    ' unsigned byte
    VT_UI2 = 18&                    ' unsigned 2 bytes integer
    VT_UI4 = 19&                    ' unsigned 4 bytes integer
    VT_I8 = 20&                     ' signed 8 bytes integer
    VT_UI8 = 21&                    ' unsigned 8 bytes integer
    VT_INT = 22&                    ' integer
    VT_UINT = 23&                   ' unsigned integer
    VT_VOID = 24&                   ' 0
    VT_HRESULT = 25&                ' HRESULT
    VT_PTR = 26&                    ' pointer
    VT_SAFEARRAY = 27&              ' safearray
    VT_CARRAY = 28&                 ' carray
    VT_USERDEFINED = 29&            ' userdefined
    VT_LPSTR = 30&                  ' LPStr
    VT_LPWSTR = 31&                 ' LPWStr
    VT_RECORD = 36&                 ' Record
    VT_FILETIME = 64&               ' File Time
    VT_BLOB = 65&                   ' Blob
    VT_STREAM = 66&                 ' Stream
    VT_STORAGE = 67&                ' Storage
    VT_STREAMED_OBJECT = 68&        ' Streamed Obj
    VT_STORED_OBJECT = 69&          ' Stored Obj
    VT_BLOB_OBJECT = 70&            ' Blob Obj
    VT_CF = 71&                     ' CF
    VT_CLSID = 72&                  ' Class ID
    VT_BSTR_BLOB = &HFFF&           ' BStr Blob
    VT_VECTOR = &H1000&             ' Vector
    VT_ARRAY = &H2000&              ' Array
    VT_BYREF = &H4000&              ' ByRef
    VT_RESERVED = &H8000&           ' Reserved
    VT_ILLEGAL = &HFFFF&            ' illegal
End Enum

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type TTYPEDESC
    #If Win64 Then
        pTypeDesc As LongLong
    #Else
        pTypeDesc As Long
    #End If
    vt   As Integer
End Type

Private Type TPARAMDESC
    #If Win64 Then
        pPARAMDESCEX  As LongLong
    #Else
        pPARAMDESCEX  As Long
    #End If
    wParamFlags  As Integer
End Type

Private Type TELEMDESC
    tdesc  As TTYPEDESC
    pdesc  As TPARAMDESC
End Type

Private Type TYPEATTR
        aGUID As GUID
        LCID As Long
        dwReserved As Long
        memidConstructor As Long
        memidDestructor As Long
        #If Win64 Then
            lpstrSchema As LongLong
        #Else
            lpstrSchema As Long
        #End If
        cbSizeInstance As Integer
        typekind As Long
        cFuncs As Integer
        cVars As Integer
        cImplTypes As Integer
        cbSizeVft As Integer
        cbAlignment As Integer
        wTypeFlags As Integer
        wMajorVerNum As Integer
        wMinorVerNum As Integer
        tdescAlias As Long
        idldescType As Long
End Type

Private Type FUNCDESC
    memid As Long
    #If Win64 Then
        lReserved1 As LongLong
        lprgelemdescParam As LongLong
    #Else
        lReserved1 As Long
        lprgelemdescParam As Long
    #End If
    funckind As Long
    INVOKEKIND As Long
    CallConv As Long
    cParams As Integer
    cParamsOpt As Integer
    oVft As Integer
    cReserved2 As Integer
    elemdescFunc As TELEMDESC
    wFuncFlags As Integer
End Type


#If VBA7 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare PtrSafe Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
#Else
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As Long, ByVal offsetinVft As Long, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As Long, ByRef retVAR As Variant) As Long
    Private Declare Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
#End If



Public Function GetObjectFunctions(ByVal TheObject As IUnknown, Optional ByVal FuncType As VbCallType) As Variant()

    #If Win64 Then
        Const vTblOffsetFac_32_64 = 2
        Dim aTYPEATTR() As LongLong, aFUNCDESC() As LongLong, farPtr As LongLong
    #Else
        Const vTblOffsetFac_32_64 = 1
        Dim aTYPEATTR() As Long, aFUNCDESC() As Long, farPtr As Long
    #End If
    
    Const CC_STDCALL As Long = 4
    Const IUNK_QueryInterface As Long = 0
    Const IDSP_GetTypeInfo As Long = 16 * vTblOffsetFac_32_64
    Const ITYP_GetTypeAttr As Long = 12 * vTblOffsetFac_32_64
    Const ITYP_GetFuncDesc As Long = 20 * vTblOffsetFac_32_64
    Const ITYP_GetDocument As Long = 48 * vTblOffsetFac_32_64
    Const ITYP_ReleaseTypeAttr As Long = 76 * vTblOffsetFac_32_64
    Const ITYP_ReleaseFuncDesc As Long = 80 * vTblOffsetFac_32_64
    
    Dim tTYPEATTR As TYPEATTR
    Dim tFUNCDESC As FUNCDESC
    Dim aGUID(0 To 11) As Long, lFuncsCount As Long
    Dim ITypeInfo As IUnknown
    Dim IDispatch As IUnknown
    Dim sName As String
    Dim lRequestedFuncsCount As Long
    Dim n As Long, index As Long


    aGUID(0) = &H20400: aGUID(2) = &HC0&: aGUID(3) = &H46000000
    Call vtblCall(ObjPtr(TheObject), IUNK_QueryInterface, vbLong, CC_STDCALL, VarPtr(aGUID(0)), VarPtr(IDispatch))
    If IDispatch Is Nothing Then MsgBox "error":   Exit Function

    Call vtblCall(ObjPtr(IDispatch), IDSP_GetTypeInfo, vbLong, CC_STDCALL, 0&, 0&, VarPtr(ITypeInfo))
    If ITypeInfo Is Nothing Then MsgBox "error": Exit Function
    
    Call vtblCall(ObjPtr(ITypeInfo), ITYP_GetTypeAttr, vbLong, CC_STDCALL, VarPtr(farPtr))
    If farPtr = 0& Then MsgBox "error": Exit Function

    Call CopyMemory(ByVal VarPtr(tTYPEATTR), ByVal farPtr, LenB(tTYPEATTR))
    ReDim aTYPEATTR(LenB(tTYPEATTR))
    Call CopyMemory(ByVal VarPtr(aTYPEATTR(0)), tTYPEATTR, UBound(aTYPEATTR))
    Call vtblCall(ObjPtr(ITypeInfo), ITYP_ReleaseTypeAttr, vbEmpty, CC_STDCALL, farPtr)
    
    If tTYPEATTR.cFuncs Then
    
        ReDim vFuncArray(tTYPEATTR.cFuncs, 6) As Variant
        
        For lFuncsCount = 0 To tTYPEATTR.cFuncs - 1
        
            Call vtblCall(ObjPtr(ITypeInfo), ITYP_GetFuncDesc, vbLong, CC_STDCALL, lFuncsCount, VarPtr(farPtr))
            If farPtr = 0 Then GoTo NextFunc
            Call CopyMemory(ByVal VarPtr(tFUNCDESC), ByVal farPtr, LenB(tFUNCDESC))
            ReDim aFUNCDESC(LenB(tFUNCDESC))
            Call CopyMemory(ByVal VarPtr(aFUNCDESC(0)), tFUNCDESC, UBound(aFUNCDESC))
            Call vtblCall(ObjPtr(ITypeInfo), ITYP_ReleaseFuncDesc, vbEmpty, CC_STDCALL, farPtr)
            Call vtblCall(ObjPtr(ITypeInfo), ITYP_GetDocument, vbLong, CC_STDCALL, aFUNCDESC(0), VarPtr(sName), 0, 0, 0)
            
            With tFUNCDESC
                If .INVOKEKIND And FuncType Then
                    vFuncArray(lFuncsCount, 0) = sName
                    vFuncArray(lFuncsCount, 1) = .memid
                    vFuncArray(lFuncsCount, 2) = .oVft
                    vFuncArray(lFuncsCount, 3) = Switch(.INVOKEKIND = 1, "VbMethod", .INVOKEKIND = 2, "VbGet", .INVOKEKIND = 4, "VbLet", .INVOKEKIND = 8, "VbSet")
                    vFuncArray(lFuncsCount, 4) = .cParams
                    vFuncArray(lFuncsCount, 5) = ReturnType(VarPtr(.elemdescFunc.tdesc))
                    lRequestedFuncsCount = lRequestedFuncsCount + 1
                End If
            End With
            sName = vbNullString
NextFunc:
            
        Next
            
        ReDim vFuncsRequestedArray(lRequestedFuncsCount, 6)
        For n = 0 To UBound(vFuncArray, 1) - 1
            If vFuncArray(n, 1) <> Empty Then
                vFuncsRequestedArray(index, 0) = vFuncArray(n, 0)
                vFuncsRequestedArray(index, 1) = vFuncArray(n, 1)
                vFuncsRequestedArray(index, 2) = vFuncArray(n, 2)
                vFuncsRequestedArray(index, 3) = vFuncArray(n, 3)
                vFuncsRequestedArray(index, 4) = vFuncArray(n, 4)
                vFuncsRequestedArray(index, 5) = vFuncArray(n, 5)
                index = index + 1
            End If
        Next n
        
        GetObjectFunctions = vFuncsRequestedArray
    
    End If

End Function



#If Win64 Then
    Private Function vtblCall(ByVal InterfacePointer As LongLong, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant

    Dim vParamPtr() As LongLong
#Else
    Private Function vtblCall(ByVal InterfacePointer As Long, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant

    Dim vParamPtr() As Long
#End If

    If InterfacePointer = 0& Or VTableOffset < 0& Then Exit Function
    If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function

    Dim pIndex As Long, pCount As Long
    Dim vParamType() As Integer
    Dim vRtn As Variant, vParams() As Variant

    vParams() = FunctionParameters()
    pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    If pCount = 0& Then
        ReDim vParamPtr(0 To 0)
        ReDim vParamType(0 To 0)
    Else
        ReDim vParamPtr(0 To pCount - 1&)
        ReDim vParamType(0 To pCount - 1&)
        For pIndex = 0& To pCount - 1&
            vParamPtr(pIndex) = VarPtr(vParams(pIndex))
            vParamType(pIndex) = VarType(vParams(pIndex))
        Next
    End If

    pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, pCount, _
    vParamType(0), vParamPtr(0), vRtn)
    If pIndex = 0& Then
        vtblCall = vRtn
    Else
        SetLastError pIndex
    End If

End Function


Private Function ReturnType(Ptr As LongPtr) As String

    Dim sName As String
    Dim tdesc   As TTYPEDESC

    Call CopyMemory(tdesc, ByVal Ptr, Len(tdesc))

    Select Case tdesc.vt
        Case VT_NULL: sName = "Long"
        Case VT_I2: sName = "Integer"
        Case VT_I4: sName = "Long"
        Case VT_R4: sName = "Single"
        Case VT_R8: sName = "Double"
        Case VT_CY: sName = "CY"
        Case VT_DATE: sName = "DATE"
        Case VT_BSTR: sName = "BSTR"
        Case VT_DISPATCH: sName = "IDispatch*"
        Case VT_ERROR: sName = "SCODE"
        Case VT_BOOL: sName = "Boolean"
        Case VT_VARIANT: sName = "VARIANT"
        Case VT_UNKNOWN: sName = "IUnknown*"
        Case VT_UI1: sName = "BYTE"
        Case VT_DECIMAL: sName = "DECIMAL"
        Case VT_I1: sName = "Char"
        Case VT_UI2: sName = "USHORT"
        Case VT_UI4: sName = "ULONG"
        Case VT_I8: sName = "__int64"
        Case VT_UI8: sName = "unsigned __int64"
        Case VT_INT: sName = "int"
        Case VT_UINT: sName = "UINT"
        Case VT_HRESULT: sName = "HRESULT"
        Case VT_VOID: sName = "VOID"
        Case VT_LPSTR: sName = "char*"
        Case VT_LPWSTR: sName = "wchar_t*"
        Case Else: sName = "ANY"
    End Select

    ReturnType = sName
    
End Function



2- Code Usage (as per the demo workbook)
VBA Code:
Option Explicit


'Example1:
'List all Methods and Properties of the excel application Object.
Sub Test_1()

    Dim oObj As Object
    Dim vFuncArray()

    Set oObj = Application ''<=== Choose here a target object as required.

    vFuncArray = GetObjectFunctions(TheObject:=oObj, FuncType:=VbGet + VbLet + VbSet + VbMethod)

    If UBound(vFuncArray) Then
        With Sheet1
            .Range("a2") = "Object Browsed:" & Space(2) & "(" & oObj.Name & ")"
            .Range("b2") = "Total Functions Found:" & Space(2) & "(" & UBound(vFuncArray, 1) & ")"
            .Range("a4").Resize(Rows.Count - 4, 6).ClearContents
            .Range("a4").Resize(UBound(vFuncArray, 1) + 1, 6) = vFuncArray
            .Range("a4").Select
        End With
    End If

End Sub


'Example2:
'List all Methods and Properties of Class1
Sub Test_2()

    Dim oClass As New Class1
    Dim vFuncArray() As Variant
    
    vFuncArray = GetObjectFunctions(TheObject:=oClass, FuncType:=VbGet + VbSet + VbLet + VbMethod)
    
    If UBound(vFuncArray) Then
        With Sheet1
            .Range("a2") = "Object Browsed:" & Space(2) & "(Class1)"
            .Range("b2") = "Total Functions Found:" & Space(2) & "(" & UBound(vFuncArray, 1) & ")"
            .Range("a4").Resize(.Rows.Count - 4, 6).ClearContents
            .Range("a4").Resize(UBound(vFuncArray, 1) + 1, 6) = vFuncArray
            .Range("a4").Select
        End With
    End If
    
End Sub
 
Upvote 2
Thank you for pointing this out to me. It's great! This will probably come in handy for a personal project I'm working on. Thank you again.
---------------
Office 365 64-bit / Windows 10 64-bit
 
Upvote 0
Thank you for pointing this out to me. It's great! This will probably come in handy for a personal project I'm working on. Thank you again.
---------------
Office 365 64-bit / Windows 10 64-bit

Dan_W

Glad you liked the code and thanks for the feedback.
BTW, there was a small error in the ReturnType function when tested in excel 2007 (forgot to do a conditional compilation from LongPtr to Long) but I have now fixed it. ITypeInfo2.xls
 
Upvote 0
This is superb. I tried to detect UDTs but is not getting them, as the sentence
It doesn't provide other info such as function arguments or return types etc.
seems to state. It's a pitty, as that functionality is handy to create "automated developes" from UDT

Also, it can not read the Modules... CPearson has some code to get the procedures (SUB/FUNCTION) of the modules: Programming In The VBA Editor

As per the UDT thing, it could somewhat be achieved reading the codeModule Lines, and looking for "Type "/"End Type" limits.

Both operations surely needs "Trust Access to VBA project" but may be worth enough. I have the code to get the UDT components disperse on my personal macros.

I cut and post my codes... sorry if there are a bunch of functions that are not posted, as the module I have to edit VBE is huge (all functions over 7.000 lines of code), but the relevant code should not be that long. If any function is not attached at first, I will try to complete afterwards. Testing on a blank workbook the code compiles without errors, so it should be fine.

Hope it helps

Code:
Option Explicit

Private Sub sMain()
' Get UDTs from all code modules
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' Need a reference to: Microsoft Visual Basic for Applications Extensibility 5.3
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    Dim strSearchText As String

    Dim oModules As Variant, oModule As Variant, lgModule As Long
    Dim aCodeLine As Variant, lgLine As Long
    Dim hndOut As Integer
    Dim aData() As String
    
    If IsVBProjectProtected Then Exit Sub

    'Referencing VBIDE Objects
    'The code below illustrate various ways to reference Extensibility objects.
    Dim ovbEditor As VBIDE.VBE
    Dim oVBProj As VBIDE.VBProject
    Dim ovbComp As VBIDE.VBComponent
    Dim ovbModule As VBIDE.CodeModule
    Dim StartLine As Long, EndLine As Long, StartColumn As Long, EndColumn As Long
    Dim strLines As String
    Dim lgPosition As Long, lgPosition´ As Long
    Dim strText As String
    Dim strID As String
    Dim variableName As String, variableType As String

    Set ovbEditor = Application.VBE
    '''''''''''''''''''''''''''''''''''''''''''
    'Set oVBProj = ovbEditor.ActiveVBProject
    ' or
    Set oVBProj = ActiveWorkbook.VBProject
    '''''''''''''''''''''''''''''''''''''''''''
    'Set oVBComp = ActiveWorkbook.VBProject.VBComponents.Item("Module1")
    ' or
    'Set oVBComp = oVBProj.VBComponents.Item("Module1")
    
    For Each ovbComp In oVBProj.VBComponents
    'For Each oModule In oModules   ' if we where with the Files method
        'Set oVBModule = ActiveWorkbook.VBProject.VBComponents.Item("Module1").CodeModule
        ' or
        Set ovbModule = ovbComp.CodeModule
        
        With ovbModule
            ' get codeLines from module
            If ovbModule.CountOfLines > 0 Then
                StartLine = 1
                EndLine = ovbModule.CountOfDeclarationLines
                StartColumn = -1
                EndColumn = -1
                strSearchText = "Type "
                If fVB_CodeModule_Search(ovbModule, strSearchText, _
                                         StartLine, EndLine, _
                                         StartColumn, EndColumn, _
                                         False, True, False, False) Then
                    If ovbModule.CountOfDeclarationLines - StartLine + 1 > 0 Then
                        strLines = .Lines(StartLine:=StartLine, Count:=ovbModule.CountOfDeclarationLines - StartLine + 1)
                        
                        aCodeLine = VBA.Split(strLines, vbNewLine)
                        For lgLine = LBound(aCodeLine) To UBound(aCodeLine)
                            If VBA.Trim$(aCodeLine(lgLine)) Like "*" & strSearchText & "*" Then
                                aData() = VBA.Split(aCodeLine(lgLine), "Type ")
                                variableName = VBA.Trim$(aData()(1))
stop: 'print out somewhere (table, inmediate Window...)
                                lgLine = lgLine + 1
                                Do
                                    'debug the UDT somewhere ...
                                    'should split each line by " As ", and get:
                                    If aCodeLine(lgLine) <> vbNullString Then
                                    If Not VBA.Trim$(aCodeLine(lgLine)) Like "[']*" Then
                                    If Not VBA.Trim$(aCodeLine(lgLine)) Like "[#]*" Then
                                    If Not VBA.Trim$(aCodeLine(lgLine)) Like "End Type*" Then
                                        aData() = VBA.Split(aCodeLine(lgLine), " As ")
                                        variableName = VBA.Trim$(aData()(0))
                                        variableType = VBA.Trim$(aData()(1))
stop: 'print out somewhere (table, inmediate Window...)
                                    End If
                                    End If
                                    End If
                                    End If
                                    lgLine = lgLine + 1
                                    DoEvents
                                Loop Until VBA.Trim$(aCodeLine(lgLine)) Like "End Type*"
                            End If
                        Next lgLine
                    End If
                End If
            End If
        End With
    'Next oModule
    Next ovbComp
End Sub

Private Function fVB_CodeModule_Search(ByRef oCodeModule As VBIDE.CodeModule, _
                                       Optional ByRef FindWhat As String = vbNullString, _
                                       Optional ByRef StartLine As Long = 1, _
                                       Optional ByRef EndLine As Long = -1, _
                                       Optional ByRef StartColumn As Long = -1, _
                                       Optional ByRef EndColumn As Long = -1, _
                                       Optional ByVal WholeWord As Boolean = True, _
                                       Optional ByVal MatchCase As Boolean = False, _
                                       Optional ByVal PatternSearch As Boolean = False, _
                                       Optional ByVal bRecursive As Boolean = False, _
                                       Optional ByRef WbkName As String = vbNullString, _
                                       Optional ByRef strModuleName As String = vbNullString) As Boolean
' Search for some text in a module
' The CodeModule object has a Find method that you can use to search for text within the code module.
' The Find method accepts ByRef Long parameters.
'   Upon input, these parameters specify the range of lines and column to search.
'   On output, these values will point to the found text.
' To find the second and subsequent occurence of the text, you need to set the parameters to refer to the text following the found line and column.
' The Find method returns True or False indicating whether the text was found.
    
    Dim bFound As Boolean
    Dim StartLine´ As Long, EndLine´ As Long, StartColumn´ As Long, EndColumn´ As Long

    If oCodeModule Is Nothing Then
        Dim oVBProj As VBIDE.VBProject
        Dim ovbComp As VBIDE.VBComponent
        
        'If WbkName = vbnullstring then WbkName = ...
        'Set oVBProj = Application.Workbooks(WbkName).VbProject
        If strModuleName = vbNullString Then
            Exit Function
        ' or let user select from a list of existing modules...
        'fVBE_IDE_Procedures_List then show and select...
        End If
        
        ' Check component exists...
        'If Not fVB_ComponentExists(strModuleName) Then Exit Function
        
        Set ovbComp = oVBProj.VBComponents.Item(strModuleName)
        Set oCodeModule = ovbComp.CodeModule
    End If
    
    With oCodeModule
        If FindWhat = vbNullString Then FindWhat = VBA.InputBox("Search for:", "Search", "")
        
        If StartLine > .CountOfLines Then fVB_CodeModule_Search = False: Exit Function
        If EndLine < StartLine Then EndLine = VBA.IIf(StartLine > .CountOfLines, .CountOfLines, StartLine)
        
        ' set StartColumn negative to search the whole line
        ' set EndColumn negative to search the whole line
        bFound = .Find(Target:=FindWhat, _
                       StartLine:=StartLine, _
                       StartColumn:=StartColumn, _
                       EndLine:=EndLine, _
                       EndColumn:=EndColumn, _
                       WholeWord:=WholeWord, _
                       MatchCase:=MatchCase, _
                       PatternSearch:=PatternSearch)
        fVB_CodeModule_Search = bFound
        
        If bRecursive Then ' will find last item
            StartColumn´ = EndColumn + 1
            Do Until bFound = False
                'Debug.Print "Found at: Line: " & CStr(StartLine) & " Column: " & CStr(StartColumn´)
                StartColumn´ = EndColumn´ + 1
                EndColumn´ = -1
                EndLine´ = .CountOfLines
                bFound = .Find(Target:=FindWhat, _
                               StartLine:=StartLine, _
                               StartColumn:=StartColumn´, _
                               EndLine:=EndLine´, _
                               EndColumn:=EndColumn´, _
                               WholeWord:=WholeWord, _
                               MatchCase:=MatchCase, _
                               PatternSearch:=PatternSearch)
            Loop
            
            ' Pass only the last one...
            EndLine = EndLine´
            EndColumn = EndColumn´
        End If
    End With
    
    Set oVBProj = Nothing
    Set ovbComp = Nothing
End Function

Private Function IsVBProjectProtected() As Boolean
' Check if the Trust Access to Visual Basic Project setting is enabled
' returns TRUE if the VB project is protected

    'Dim ovbEditor As VBIDE.VBE
    Dim oVBProj As VBIDE.VBProject
    Dim oCom As VBIDE.VBComponent
    Dim vbc As Integer
    Dim retValue As VbMsgBoxResult
    
    On Error Resume Next
    'Set oVBProj = ActiveWorkbook.VbProject
    Set oVBProj = Application.VBE.ActiveVBProject.VBComponents(1) 'VBE.ActiveVBProject gives error...

    If Err.Number = 13 Then
       'retValue = MsgBox("Trust Access to the VBA Project Object Model is correctly enabled.")
       IsVBProjectProtected = False
    Else
       Err.Clear
       retValue = MsgBox("Program cannot run with current security settings" & vbNewLine & vbNewLine & _
                             "Go to the Developer tab --> macros security tab, and set:" & _
                             "[Enable trust access to the VBA project object model] = True" & vbNewLine & _
                             "Then Save, Exit and Restart Program.", _
                             vbCritical)
       IsVBProjectProtected = True
    End If
    On Error GoTo 0
End Function
 
Upvote 0
Hi Jaafar,
yeap, they are not objects, but a bit related. If you are exploring classes, and exposing their variables and all Properties procedures, the UDT would be a nice feature in the report table, so that you get all the methods/variables/procedures in the class or module. Another feature I would expect will be to get the Sub/Function procedures with some information on them, it could be done with similar code to exposed. Just to ease things.

For me the TLBNINF32 replacement is a neat function I was looking for. I had several codes collected, promissing, but did not get time to put my hands on them. Maybe they could work, maybe not, for sure they gonna take me some time to work it out. But you have provided the funcionality I was looking for... solved my issue!. The UDT and the Sub/Function analysis is something I had already solved. So now I close the circle. Thank you so much.

Kind regards
 
Upvote 0

Forum statistics

Threads
1,223,886
Messages
6,175,189
Members
452,616
Latest member
intern444

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top