Turn Excel VBA Object Browser into a 4-column long list

RomulusMilea

Board Regular
Joined
May 11, 2002
Messages
181
Hello All,

I need an Excel macro that will loop through following object libraries: Excel, Office, stdole, and VBA, then for each library will loop through all object Classes, on each class it will loop through all class members and create a table having following 4 columns: Library, Class, Member and Type, where type can be Function, Constant, Sub, Property, Enum, etc.

Table must start from cell A1 of the Sheet1 tab.

I suppose I need to activate/tick first Microsoft Visual Basic for Applications Extensibility 5.3.

I expect the list will contain thousands of rows, maybe more.

This would basically be an exact replica of Excel Object Browser, but turned into an Excel list. I need it for a personal project.

1711389317660.png


Could anyone please generate the code ? Or is the code available somewhere else ?

Thank you in advance !

Regards,
Romulus.
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
No, it does not help. Those codes refer to certain already created module(s), I did not ask for that. I would have appreciated a solution, not a link to a page that refers to something else. The chances I will receive now a solution are now really low, because my thread appears as answered, which in fact is not true :(.
 
Upvote 0
A reminder:

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at:

There is no need to repeat the link(s) provided above but if you have posted the question at other places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.

You also might want to rethink your tone towards people who are trying to help you.
 
Upvote 0
Hello @RoryA,

Thank you for the reminder. I was not fully aware of it. I have also read that article published by Ken Puls, annexed to rule no. 13. I did not mean to upset anyone, I am just looking for a solution to my request. I am also sorry if my tone was inappropriate, I did not mean it. Please accept my apologies.

Do you maybe recommend someone on this forum, who can help me, please ? Thank you once again.

Regards,
Romulus.
 
Upvote 0
@RoryA,

Thank you. I never assumed there was a quick and easy solution to my request. I will have a look on the link you sent. Also, I certainly hope someone will eventually propose a solution.
 
Upvote 0
Do bear in mind that tlbinf32.dll won't work in x64 bit.

Some time ago, I posted some vba code here for retrieving Enums from libraries and other code for getiing the list of Properties and Methods of objects. The codes work in x32 as well as in x64 and no 3rd party dlls are required nor registration. All is done with vba alone.

I was in the process of writing a more comprehensive vba code to mimic the VBE Object Browser but I abandoned it half way. I am going to revisit this half finished project again and see if I can complete it and will post the final result in this thread.
 
Upvote 0
Do bear in mind that tlbinf32.dll won't work in x64 bit.

Some time ago, I posted some vba code here for retrieving Enums from libraries and other code for getiing the list of Properties and Methods of objects. The codes work in x32 as well as in x64 and no 3rd party dlls are required nor registration. All is done with vba alone.

I was in the process of writing a more comprehensive vba code to mimic the VBE Object Browser but I abandoned it half way. I am going to revisit this half finished project again and see if I can complete it and will post the final result in this thread.
Hello Jaafar,

Thank you a lot for your answer, you gave me a wonderful piece of news. I am looking forward to reading and trying the solution you are working on.

Cheers,
Romulus.
 
Upvote 0
Hi, sorry for not getting back sooner but completing the project and debugging it wasn't easy.

Testing so far, the code seems to work ok for browsing typelibs ... The code works by making direct low level vtable calls on the ITypeLib and ITYpeInfo interfaces therefore, all is achieved @runtime w/o the need to use (or register) any external 3rd party libs for the job.

The browser allows the user to choose from already referenced type libraries in the vbproject (Tools|References) and from all other modules that are laoded by the vba host application process.

Project Requirements:
' - This project requires a reference to Visual Basic for Applications Extensibility.
' - 'Trust access to Visual Basic Project' must also be set.

Still to be done:
' - Exporting the typelibs to worksheets, txt files, etc
' - Didn't know how to distinguish between Methods and Events.
' - Didn't know how to figure out Default Interfaces.

File Demo:
VBA_Custom_ObjBrowser.xlsm






1- API calls in a Standard Module:
VBA Code:
'\ This VBA project browses typelibs at runtime via low level vTable calls.

'\ Requiremets:
'\ ===========
'   - This project requires a reference to Visual Basic for Applications Extensibility.
'   - 'Trust access to Visual Basic Project' must also be set.

Option Explicit

Public Enum SEARCH_TARGET
    Class_
    Interface_
    Module_
    Enum_
End Enum

Private Const TKIND_ENUM = 0&
Public Enum TKIND
    EI = TKIND_ENUM
    MI = TKIND_ENUM + 2&  'TKIND_MODULE
    II = TKIND_ENUM + 3&  'TKIND_INTERFACE
    CI = TKIND_ENUM + 5&  'TKIND_COCLASS
    DI = TKIND_ENUM + 4&  'TKIND_DISPATCH
End Enum

Private Enum VarEnum
    VT_EMPTY = 0&
    VT_NULL = 1&
    VT_I2 = 2&
    VT_I4 = 3&
    VT_R4 = 4&
    VT_R8 = 5&
    VT_CY = 6&
    VT_DATE = 7&
    VT_BSTR = 8&
    VT_DISPATCH = 9&
    VT_ERROR = 10&
    VT_BOOL = 11&
    VT_VARIANT = 12&
    VT_UNKNOWN = 13&
    VT_DECIMAL = 14&
    VT_I1 = 16&
    VT_UI1 = 17&
    VT_UI2 = 18&
    VT_UI4 = 19&
    VT_I8 = 20&
    VT_UI8 = 21&
    VT_INT = 22&
    VT_UINT = 23&
    VT_VOID = 24&
    VT_HRESULT = 25&
    VT_PTR = 26&
    VT_SAFEARRAY = 27&
    VT_CARRAY = 28&
    VT_USERDEFINED = 29&
    VT_LPSTR = 30&
    VT_LPWSTR = 31&
    VT_RECORD = 36&
    VT_FILETIME = 64&
    VT_BLOB = 65&
    VT_STREAM = 66&
    VT_STORAGE = 67&
    VT_STREAMED_OBJECT = 68&
    VT_STORED_OBJECT = 69&
    VT_BLOB_OBJECT = 70&
    VT_CF = 71&
    VT_CLSID = 72&
    VT_BSTR_BLOB = &HFFF&
    VT_VECTOR = &H1000&
    VT_ARRAY = &H2000&
    VT_BYREF = &H4000&
    VT_RESERVED = &H8000&
    VT_ILLEGAL = &HFFFF&
End Enum

#If Win64 Then
    Private Const NULL_PTR = 0^
    Private Const PTR_LEN = 8&
#Else
    Private Const NULL_PTR = 0&
    Private Const PTR_LEN = 4&
#End If

#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 SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long
    Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV 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)
    Private Declare PtrSafe Function StringFromIID Lib "ole32" (ByRef lpsz As GUID, ByVal rclsid As LongPtr) As Long
    Private Declare PtrSafe Function LoadTypeLibEx Lib "OleAut32" (ByVal szFile As LongPtr, ByVal regkind As Long, ByRef pptlib As IUnknown) As Long
    Private Declare PtrSafe Function GetCurrentProcess Lib "kernel32" () As LongPtr
    Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetModuleInformation Lib "psapi.dll" (ByVal hProcess As LongPtr, ByVal hModule As LongPtr, mInfo As MODULEINFO, ByVal cbSize As Long) As Long
    Private Declare PtrSafe Function GetModuleFileNameExW Lib "psapi.dll" (ByVal hProcess As LongPtr, ByVal hModule As LongPtr, ByVal lpFileName As LongPtr, ByVal nSize As Long) As Long
    Private Declare PtrSafe Function EnumProcessModules Lib "psapi.dll" (ByVal hProcess As LongPtr, lphModule As LongPtr, ByVal cb As Long, lpcbNeeded As Long) As Long
    Private Declare PtrSafe Function GetModuleBaseNameW Lib "psapi.dll" (ByVal hProcess As LongPtr, ByVal hModule As LongPtr, ByVal lpFileName As LongPtr, ByVal nSize As Long) As Long
    Private Declare PtrSafe Function GetModuleFileNameW Lib "kernel32" (ByVal hModule As LongPtr, ByVal lpFileName As LongPtr, ByVal nSize As Long) As Long
    Private Declare PtrSafe Function GetModuleHandleW Lib "kernel32" (ByVal lpModuleName As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As LongPtr, ByVal lpFileName As String, ByVal nSize As Long) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long
    Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As LongPtr)
    Private Declare 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 Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
    Private Declare Function StringFromIID Lib "ole32" (ByRef lpsz As GUID, ByVal rclsid As LongPtr) As Long
    Private Declare Function LoadTypeLibEx Lib "OleAut32" (ByVal szFile As LongPtr, ByVal regkind As Long, ByRef pptlib As IUnknown) As Long
    Private Declare Function GetCurrentProcess Lib "kernel32" () As LongPtr
    Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As Long
    Private Declare Function GetModuleInformation Lib "psapi.dll" (ByVal hProcess As LongPtr, ByVal hModule As LongPtr, mInfo As MODULEINFO, ByVal cbSize As Long) As Long
    Private Declare Function GetModuleFileNameExW Lib "psapi.dll" (ByVal hProcess As LongPtr, ByVal hModule As LongPtr, ByVal lpFileName As LongPtr, ByVal nSize As Long) As Long
    Private Declare Function EnumProcessModules Lib "psapi.dll" (ByVal hProcess As LongPtr, lphModule As LongPtr, ByVal cb As Long, lpcbNeeded As Long) As Long
    Private Declare Function GetModuleBaseNameW Lib "psapi.dll" (ByVal hProcess As LongPtr, ByVal hModule As LongPtr, ByVal lpFileName As LongPtr, ByVal nSize As Long) As Long
    Private Declare Function GetModuleFileNameW Lib "kernel32" (ByVal hModule As LongPtr, ByVal lpFileName As LongPtr, ByVal nSize As Long) As Long
    Private Declare Function GetModuleHandleW Lib "kernel32" (ByVal lpModuleName As LongPtr) As LongPtr
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As LongPtr, ByVal lpFileName As String, ByVal nSize As Long) As Long
#End If

Public Type FUNC_INFO
    Name As String
    memid As Long
    CallConvention As Long
    funckind As Long
    VTBLOffset As Long
    INVOKEKIND As String
    ParamsCount As Long
    OptParamsCount As Long
    ReturnType As String
End Type

Public Type INTERFACE_INFO
    ptr As LongPtr
    GUID As String
    lcid As Long
    memidConstructor As Long
    memidDestructor As Long
    Name As String
    MembersCount As Long
    InterfacesCount As Long
    wMajorVerNum As Integer
    wMinorVerNum As Integer
End Type

Public Type SPECIAL_ENUMS
    'Special vba ENUMS not defined in the enumerations module.
    Caption() As String
    Value() As String
End Type

Public Type ENUM_VALS
    Name As String
    Value As String
End Type

Public Type TEXT_STRUCT
    Caption As String
    Value As String
End Type

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

Private Type DUMMYUNIONNAME_TYPE
    oInst As Long
    lpvarValue As LongPtr
End Type

Private Type VARDESC
    memid As Long
    lpstrSchema As LongPtr
    DUMMYUNIONNAME As LongPtr
    elemdescVar As Long
    wVarFlags As Long
    varkind As Long
End Type

Private Type TTYPEDESC
    pTypeDesc As LongPtr
    vt As Integer
End Type
    
Private Type TPARAMDESC
    pPARAMDESCEX  As LongPtr
    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
    lpstrSchema As LongPtr
    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
    lReserved1 As LongPtr
    lprgelemdescParam As LongPtr
    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

Private Type MODULEINFO
    lpBaseOfDll As LongPtr
    SizeofImage As Long
    EntryPoint As LongPtr
End Type

Private Type INFO
    CI() As INTERFACE_INFO
    MI() As INTERFACE_INFO
    EI() As INTERFACE_INFO
    DI() As INTERFACE_INFO
End Type

Private Type ARRAYS
    arrClasses() As INTERFACE_INFO
    arrInterfaces() As INTERFACE_INFO
    arrDisps() As INTERFACE_INFO
    arrModules() As INTERFACE_INFO
    arrEnums() As INTERFACE_INFO
    arrTypes() As SEARCH_TARGET
    arrNames() As String
    arrFuncPtrs() As FUNC_INFO
    arrEnumPtrs() As ENUM_VALS
    arrPtrs() As LongPtr
    arrOtherInfo1() As TEXT_STRUCT
    arrOtherInfo2() As TEXT_STRUCT
End Type

Public tArrays As ARRAYS


Function RetrieveLibInfo(ByVal sFile As String) As Boolean

    Dim lArrRows As Long
    Dim i As Long, j As Long
    
    Call EraseArrays
    
    With tArrays
        .arrClasses = TypeInfoFromCOMLib(sFile, CI).CI
        If (Not Not .arrClasses) = False Then
            Exit Function
        End If
        
        For i = LBound(.arrClasses) To UBound(.arrClasses)
            .arrInterfaces = InterFacesFromClass(.arrClasses(i))
            For j = LBound(.arrInterfaces) To UBound(.arrInterfaces)
                ReDim Preserve .arrNames(lArrRows):          ReDim Preserve .arrPtrs(lArrRows)
                ReDim Preserve .arrTypes(lArrRows):          ReDim Preserve .arrOtherInfo1(lArrRows)
                ReDim Preserve .arrOtherInfo2(lArrRows)
                .arrNames(lArrRows) = ChrW(&H25A0) & " " & .arrInterfaces(j).Name
                .arrPtrs(lArrRows) = .arrInterfaces(j).ptr:   .arrTypes(lArrRows) = Class_
                .arrOtherInfo1(lArrRows) = BuildClassInfoString(.arrInterfaces(j), False)
                .arrOtherInfo2(lArrRows) = BuildClassInfoString(.arrInterfaces(j), True)
                lArrRows = lArrRows + 1&
            Next j
        Next i
    
        .arrDisps = TypeInfoFromCOMLib(sFile, DI).DI
        If Not Not .arrDisps Then
            For i = LBound(.arrDisps) To UBound(.arrDisps)
                ReDim Preserve .arrNames(lArrRows):          ReDim Preserve .arrPtrs(lArrRows)
                ReDim Preserve .arrTypes(lArrRows):          ReDim Preserve .arrOtherInfo1(lArrRows)
                ReDim Preserve .arrOtherInfo2(lArrRows)
                .arrNames(lArrRows) = ChrW(&H25A0) & " " & .arrDisps(i).Name
                .arrPtrs(lArrRows) = .arrDisps(i).ptr:      .arrTypes(lArrRows) = Interface_
                .arrOtherInfo1(lArrRows) = BuildClassInfoString(.arrDisps(i), False)
                .arrOtherInfo2(lArrRows) = BuildClassInfoString(.arrDisps(i), True)
                lArrRows = lArrRows + 1&
            Next
        End If
    
        .arrModules = TypeInfoFromCOMLib(sFile, MI).MI
        If Not Not .arrModules Then
            For i = LBound(.arrModules) To UBound(.arrModules)
                ReDim Preserve .arrNames(lArrRows):          ReDim Preserve .arrPtrs(lArrRows)
                ReDim Preserve .arrTypes(lArrRows):          ReDim Preserve .arrOtherInfo1(lArrRows)
                ReDim Preserve .arrOtherInfo2(lArrRows)
                .arrNames(lArrRows) = ChrW(&H25E5) & " " & .arrModules(i).Name
                .arrPtrs(lArrRows) = .arrModules(i).ptr:     .arrTypes(lArrRows) = Module_
                .arrOtherInfo1(lArrRows) = BuildClassInfoString(.arrModules(i), False)
                .arrOtherInfo2(lArrRows) = BuildClassInfoString(.arrModules(i), True)
                lArrRows = lArrRows + 1&
            Next i
        End If
    
        .arrEnums = TypeInfoFromCOMLib(sFile, EI).EI
        If Not Not .arrEnums Then
            For i = LBound(.arrEnums) To UBound(.arrEnums)
                ReDim Preserve .arrNames(lArrRows):          ReDim Preserve .arrPtrs(lArrRows)
                ReDim Preserve .arrTypes(lArrRows):          ReDim Preserve .arrOtherInfo1(lArrRows)
                ReDim Preserve .arrOtherInfo2(lArrRows)
               .arrNames(lArrRows) = ChrW(&H25CD) & " " & .arrEnums(i).Name
               .arrPtrs(lArrRows) = .arrEnums(i).ptr:         .arrTypes(lArrRows) = Enum_
                .arrOtherInfo1(lArrRows) = BuildClassInfoString(.arrEnums(i), False)
                .arrOtherInfo2(lArrRows) = BuildClassInfoString(.arrEnums(i), True)
                lArrRows = lArrRows + 1&
            Next i
        End If
    End With

    RetrieveLibInfo = True

End Function

Sub EraseArrays()
    With tArrays
        Erase .arrClasses():     Erase .arrInterfaces()
        Erase .arrDisps():       Erase .arrModules()
        Erase .arrEnums():       Erase .arrTypes()
        Erase .arrNames():       Erase .arrFuncPtrs()
        Erase .arrEnumPtrs():    Erase .arrPtrs()
        Erase .arrOtherInfo1():  Erase .arrOtherInfo2()
    End With
End Sub


Function TypeInfoFromCOMLib(ByVal sLibFile As String, ByVal eRequestedInfo As TKIND) As INFO

    Const REGKIND_NONE = 2&, MEMBERID_NIL = -1&
    Const TKIND_COCLASS = 5&, TKIND_MODULE = 2&, TKIND_ENUM = 0&, TKIND_DISPATCH = 4&
    Const S_OK = 0&, CC_STDCALL = 4&
    Dim pTKind As LongPtr, ppTInfo As LongPtr, farPtr As LongPtr, psGUID As LongPtr
    Dim tClassInfo As INTERFACE_INFO, tModuleInfo As INTERFACE_INFO
    Dim tDispInfo As INTERFACE_INFO, tEnumInfo As INTERFACE_INFO
    Dim tInfoArray As INFO
    Dim tTYPEATTR As TYPEATTR
    Dim unkTypLib As stdole.IUnknown
    Dim i As Long, j As Long, lRet As Long, lInfoCount As Long
    Dim sName As String
    
    lRet = LoadTypeLibEx(StrPtr(sLibFile), REGKIND_NONE, unkTypLib)
    If lRet <> S_OK Then
        MsgBox "Unable to load the " & sLibFile & " library.": Exit Function
    End If
    lInfoCount = vtblCall(ObjPtr(unkTypLib), 3& * PTR_LEN, vbLong, CC_STDCALL) 'ITypeLib::GetTypeInfoCount
    For i = 0& To lInfoCount - 1&
        lRet = vtblCall(ObjPtr(unkTypLib), 5& * PTR_LEN, vbLong, CC_STDCALL, i, VarPtr(pTKind)) ' ITypeLib::GetTypeInfoType
        If lRet <> S_OK Then
            MsgBox "Unable to retrieve the type of a type description.": Exit Function
        End If
        If pTKind = eRequestedInfo Then
            Select Case eRequestedInfo
                Case Is = CI
                    ReDim Preserve tInfoArray.CI(j)
                Case Is = MI
                    ReDim Preserve tInfoArray.MI(j)
                Case Is = DI
                    ReDim Preserve tInfoArray.DI(j)
                Case Is = EI
                    ReDim Preserve tInfoArray.EI(j)
            End Select
            lRet = vtblCall(ObjPtr(unkTypLib), 4& * PTR_LEN, vbLong, CC_STDCALL, i, VarPtr(ppTInfo)) 'ITypeLib::GetTypeInfo
            If lRet <> S_OK Then
                MsgBox "Unable to retrieve the specified type description in the library.": Exit Function
            End If
            lRet = vtblCall(ppTInfo, 3& * PTR_LEN, vbLong, CC_STDCALL, VarPtr(farPtr)) 'ITypeInfo::GetTypeAttr
            If lRet <> S_OK Then
                MsgBox "Unable to retrieve a TYPEATTR structure that contains the attributes of the type description."
                Exit Function
            End If
            Call CopyMemory(tTYPEATTR, ByVal farPtr, LenB(tTYPEATTR))
            lRet = vtblCall(ppTInfo, 19& * PTR_LEN, vbEmpty, CC_STDCALL, farPtr) 'ITypeInfo::ReleaseTypeAttr
            Call StringFromIID(tTYPEATTR.aGUID, VarPtr(psGUID))
             lRet = vtblCall(ppTInfo, 12& * PTR_LEN, vbLong, CC_STDCALL, MEMBERID_NIL, VarPtr(sName), NULL_PTR, NULL_PTR, NULL_PTR)  'ITypeInfo::GetDocumentation
            If lRet <> S_OK Then
                MsgBox "Unable to retrieve the documentation string.": Exit Function
            End If
            Select Case pTKind
                Case Is = TKIND_COCLASS
                    With tClassInfo
                        .ptr = ppTInfo
                        .GUID = GetStrFromPtrW(psGUID)
                        .lcid = tTYPEATTR.lcid
                        .memidConstructor = tTYPEATTR.memidConstructor
                        .memidDestructor = tTYPEATTR.memidDestructor
                        .Name = sName
                        .MembersCount = tTYPEATTR.cFuncs
                        .InterfacesCount = tTYPEATTR.cImplTypes
                        .wMajorVerNum = tTYPEATTR.wMajorVerNum
                .wMinorVerNum = tTYPEATTR.wMinorVerNum
                    End With
                    tInfoArray.CI(j) = tClassInfo
                Case Is = TKIND_MODULE
                    With tModuleInfo
                        .ptr = ppTInfo
                        .GUID = GetStrFromPtrW(psGUID)
                        .lcid = tTYPEATTR.lcid
                        .memidConstructor = tTYPEATTR.memidConstructor
                        .memidDestructor = tTYPEATTR.memidDestructor
                        .Name = sName
                        .MembersCount = tTYPEATTR.cFuncs + tTYPEATTR.cVars
                        .InterfacesCount = tTYPEATTR.cImplTypes
                        .wMajorVerNum = tTYPEATTR.wMajorVerNum
                        .wMinorVerNum = tTYPEATTR.wMinorVerNum
                    End With
                    tInfoArray.MI(j) = tModuleInfo
                 Case Is = TKIND_DISPATCH
                    With tDispInfo
                        .ptr = ppTInfo
                        .GUID = GetStrFromPtrW(psGUID)
                        .lcid = tTYPEATTR.lcid
                        .memidConstructor = tTYPEATTR.memidConstructor
                        .memidDestructor = tTYPEATTR.memidDestructor
                        .Name = sName
                        .MembersCount = tTYPEATTR.cFuncs + tTYPEATTR.cVars
                        .InterfacesCount = tTYPEATTR.cImplTypes
                        .wMajorVerNum = tTYPEATTR.wMajorVerNum
                        .wMinorVerNum = tTYPEATTR.wMinorVerNum
                    End With
                    tInfoArray.DI(j) = tDispInfo
                Case Is = TKIND_ENUM
                    With tEnumInfo
                        .ptr = ppTInfo
                        .GUID = GetStrFromPtrW(psGUID)
                        .lcid = tTYPEATTR.lcid
                        .memidConstructor = tTYPEATTR.memidConstructor
                        .memidDestructor = tTYPEATTR.memidDestructor
                        .Name = sName
                        .MembersCount = tTYPEATTR.cVars
                        .wMajorVerNum = tTYPEATTR.wMajorVerNum
                        .wMinorVerNum = tTYPEATTR.wMinorVerNum
                    End With
                    tInfoArray.EI(j) = tEnumInfo
            End Select
            j = j + 1&
        End If
    Next
    TypeInfoFromCOMLib = tInfoArray

End Function

Function GetFuncs(ByVal ppTInfo As LongPtr, Optional ByVal FuncCallType As VbCallType, Optional ByVal unk As Boolean) As FUNC_INFO()
    
    Const CC_STDCALL = 4&, S_OK = 0&
    Dim aTYPEATTR() As LongPtr, aFUNCDESC() As LongPtr, farPtr As LongPtr
    Dim tTYPEATTR As TYPEATTR, tFuncDesc As FUNCDESC, tFuncDescArray() As FUNC_INFO
    Dim aGUID(0& To 11&) As Long
    Dim lRet As Long, lFuncsCount As Long, n As Long
    Dim sFuncName As String
    Dim IUnkIDisp As Variant
    
    lRet = vtblCall(ppTInfo, 3& * PTR_LEN, vbLong, CC_STDCALL, VarPtr(farPtr))  'ITypeInfo::GetTypeAttr
    If lRet <> S_OK Then
        MsgBox "Unable to retrieve a TYPEATTR structure that contains the attributes of the type description."
        Exit Function
    End If
    Call CopyMemory(ByVal VarPtr(tTYPEATTR), ByVal farPtr, LenB(tTYPEATTR))
    ReDim aTYPEATTR(LenB(tTYPEATTR))
    Call CopyMemory(ByVal VarPtr(aTYPEATTR(0&)), tTYPEATTR, UBound(aTYPEATTR))
    lRet = vtblCall(ppTInfo, 19& * PTR_LEN, vbEmpty, CC_STDCALL, farPtr)  'ITypeInfo::ReleaseTypeAttr
    If tTYPEATTR.cFuncs Then
        For lFuncsCount = 0& To tTYPEATTR.cVars + tTYPEATTR.cFuncs - 1&
            lRet = vtblCall(ppTInfo, 5& * PTR_LEN, vbLong, CC_STDCALL, lFuncsCount, VarPtr(farPtr)) 'ITypeInfo::GetFuncDesc
            If farPtr = NULL_PTR Then Exit Function
            If lRet <> S_OK Then
                MsgBox "Unable to retrieve the FUNCDESC structure that contains information about a specified function."
                Exit Function
            End If
            If farPtr = NULL_PTR 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))
            lRet = vtblCall(ppTInfo, 20& * PTR_LEN, vbEmpty, CC_STDCALL, farPtr) 'ITypeInfo::ReleaseFuncDesc
            lRet = vtblCall(ppTInfo, 12& * PTR_LEN, vbLong, CC_STDCALL, aFUNCDESC(0), VarPtr(sFuncName), NULL_PTR, NULL_PTR, NULL_PTR)  'ITypeInfo::GetDocumentation
            If lRet <> S_OK Then
                MsgBox "Unable to retrieve the documentation string.": Exit Function
            End If
            IUnkIDisp = Array("QueryInterface", "AddRef", "Release", "GetTypeInfoCount", "GetTypeInfo", "GetIDsOfNames", "Invoke")
            If IsError(Application.Match(sFuncName, IUnkIDisp, 0&)) = False And unk = False Then GoTo NextFunc
            With tFuncDesc
                If (.INVOKEKIND And FuncCallType) = .INVOKEKIND Then
                    ReDim Preserve tFuncDescArray(n)
                    tFuncDescArray(n).Name = sFuncName
                    tFuncDescArray(n).memid = .memid
                    tFuncDescArray(n).CallConvention = .CallConv
                    tFuncDescArray(n).funckind = .funckind
                    tFuncDescArray(n).VTBLOffset = .oVft
                    tFuncDescArray(n).INVOKEKIND = Switch(.INVOKEKIND = 1&, "VbMethod", .INVOKEKIND = 2&, "VbGet", .INVOKEKIND = 4&, "VbLet", .INVOKEKIND = 8&, "VbSet")
                    tFuncDescArray(n).ParamsCount = .cParams
                    tFuncDescArray(n).OptParamsCount = .cParamsOpt
                    tFuncDescArray(n).ReturnType = ReturnType(.elemdescFunc.tdesc.vt)
                    n = n + 1&
                End If
            End With
NextFunc:
            If lFuncsCount Mod 100& = 0& Then DoEvents
        Next
        GetFuncs = tFuncDescArray
    End If

End Function

Function MembersFromEnum(pEnum As LongPtr) As ENUM_VALS()

    Const S_OK = 0&, CC_STDCALL = 4&
    Dim ppTypeAttr As LongPtr, pcNames As LongPtr
    Dim tTYPEATTR As TYPEATTR, tVARDESC As VARDESC
    Dim tDUMMYUNIONNAME As DUMMYUNIONNAME_TYPE, tLRG_INT As LARGE_INT
    Dim pVARDESC  As LongPtr, BstrName As String
    Dim vRet() As ENUM_VALS
    Dim i As Long, lRet As Long
    
    lRet = vtblCall(pEnum, 3& * PTR_LEN, vbLong, CC_STDCALL, VarPtr(ppTypeAttr)) 'ITypeInfo::GetTypeAttr
    If lRet <> S_OK Then
        MsgBox "Unable to retrieve a TYPEATTR structure that contains the attributes of the type description."
        Exit Function
    End If
    If ppTypeAttr = NULL_PTR Then Exit Function
    Call CopyMemory(ByVal VarPtr(tTYPEATTR), ByVal ppTypeAttr, LenB(tTYPEATTR))
    lRet = vtblCall(pEnum, 19& * PTR_LEN, vbEmpty, CC_STDCALL, ppTypeAttr) 'ITypeInfo::ReleaseTypeAttr
    ReDim vRet(tTYPEATTR.cVars - 1&)
    For i = 0& To tTYPEATTR.cVars - 1&
        lRet = vtblCall(pEnum, 6& * PTR_LEN, vbLong, CC_STDCALL, i, VarPtr(pVARDESC)) 'ITypeInfo::GetVarDesc
        If lRet <> S_OK Then
            MsgBox "Unable to retrieves a VARDESC structure that describes the specified variable."
            Exit Function
        End If
        Call CopyMemory(ByVal VarPtr(tVARDESC), ByVal pVARDESC, LenB(tVARDESC))
        lRet = vtblCall(pEnum, 7& * PTR_LEN, vbLong, CC_STDCALL, tVARDESC.memid, VarPtr(BstrName), tTYPEATTR.cVars, VarPtr(pcNames))  'ITypeInfo::GetNames
        If lRet <> S_OK Then
            MsgBox "Unable to retrieves the variable with the specified member ID or the name of the property or method."
            Exit Function
        End If
        Call CopyMemory(tDUMMYUNIONNAME, ByVal tVARDESC.DUMMYUNIONNAME, Len(tDUMMYUNIONNAME))
        Call CopyMemory(ByVal tLRG_INT, tDUMMYUNIONNAME.lpvarValue, PTR_LEN)
        vRet(i).Name = BstrName
        vRet(i).Value = tLRG_INT.LowPart
        MembersFromEnum = vRet
    Next i

End Function

Function BuildFuncInfoString(INFO As FUNC_INFO) As TEXT_STRUCT
    Dim tString As TEXT_STRUCT
    With tString
        .Caption = _
            "[Member Name:]" & vbLf & _
            "[INVOKEKIND:]" & vbLf & _
            "[memid:]" & vbLf & _
            "[ParamsCount:]" & vbLf & _
            "[Opt ParamsCount:]" & vbLf & _
            "[Funckind:]" & vbLf & _
            "[VTBLOffset:]" & vbLf & _
            "[CallConvention:]" & vbLf & _
            "[ReturnType:]"
        .Value = _
            INFO.Name & vbLf & _
            INFO.INVOKEKIND & vbLf & _
            INFO.memid & vbLf & _
            INFO.ParamsCount & vbLf & _
            INFO.OptParamsCount & vbLf & _
            INFO.funckind & vbLf & _
            Hex(INFO.VTBLOffset) & vbLf & _
            INFO.CallConvention & vbLf & _
            INFO.ReturnType
    End With
    BuildFuncInfoString = tString
End Function

Function BuildEnumInfoString(INFO As ENUM_VALS) As TEXT_STRUCT
    Dim tString As TEXT_STRUCT
    With tString
        .Caption = _
            "[Const Name:]" & vbLf & _
            "[Value:]"
        .Value = _
            INFO.Name & vbLf & _
            INFO.Value
     End With
    BuildEnumInfoString = tString
End Function

Function RefLibNameToFullPath(ByVal ReferenceLibName As String) As String
    '[ Requires References :: Visual Basic for Applications Extensibility And Trust access to Visual Basic Project ]
    Dim oRef As VBIDE.Reference, oRefs As VBIDE.References, i As Integer
    On Error Resume Next
    Set oRefs = Application.VBE.ActiveVBProject.References
        For Each oRef In oRefs
        i = i + 1&
        If LCase(oRef.Name) = LCase(ReferenceLibName) Then
            RefLibNameToFullPath = oRef.FullPath:   Exit For
        End If
    Next oRef
End Function

Function GetVBEReferencesList() As String()
    '[ Requires References :: Visual Basic for Applications Extensibility And Trust access to Visual Basic Project ]
    Dim oRef As VBIDE.Reference, oRefs As VBIDE.References, i As Integer, tmpArray() As String
    Set oRefs = Application.VBE.ActiveVBProject.References
    For Each oRef In oRefs
        ReDim Preserve tmpArray(i)
        tmpArray(i) = oRef.Name: i = i + 1&
    Next oRef
    GetVBEReferencesList = tmpArray
End Function

Function GUIDFromLib(ByVal LibPathName As String) As String
    '[ Requires References :: Visual Basic for Applications Extensibility And Trust access to Visual Basic Project ]
    Dim oRef As VBIDE.Reference, oRefs As VBIDE.References
    Set oRefs = Application.VBE.ActiveVBProject.References
    On Error Resume Next
    For Each oRef In oRefs
        If oRef.FullPath = LibPathName Then
            GUIDFromLib = oRef.GUID: Exit For
        End If
    Next oRef
End Function

Function GetSpecialEnum(sEnum As String) As Boolean
    'Handle special vba constants not defined in the enumerations module.
    Dim a() As Variant, v As Variant
    a = Array("Constants", "KeyCodeConstants", "ColorConstants", "SystemColorConstants")
    For Each v In a
        If ChrW(&H25E5) & " " & v = sEnum Then
            GetSpecialEnum = True: Exit Function
        End If
    Next v
End Function

Function BuildSpecailEnumValues(ByVal sEnum As String, Optional sPfx As String) As SPECIAL_ENUMS

    Dim X() As String, y() As String

    Select Case sEnum
        Case ChrW(&H25E5) & " " & "Constants"
            ReDim X(10):                                ReDim y(10)
            X(0) = sPfx & "vbObjectError":              y(0) = -2147221504
            X(1) = sPfx & "vbNullString":               y(1) = vbNullString
            X(2) = sPfx & "vbNullChar":                 y(2) = vbNullChar
            X(3) = sPfx & "vbCrLf":                     y(3) = vbCrLf
            X(4) = sPfx & "vbNewLine":                  y(4) = vbNewLine
            X(5) = sPfx & "vbCr":                       y(5) = vbCr
            X(6) = sPfx & "vbLf":                       y(6) = vbLf
            X(7) = sPfx & "vbBack":                     y(7) = vbBack
            X(8) = sPfx & "vbFormFeed":                 y(8) = vbFormFeed
            X(9) = sPfx & "vbTab":                      y(9) = vbTab
            X(10) = sPfx & "vbVerticalTab":             y(10) = vbVerticalTab
    
        Case ChrW(&H25E5) & " " & "KeyCodeConstants"
            ReDim X(98):                                ReDim y(98)
            X(0) = sPfx & "vbKeyLButton":               y(0) = 1
            X(1) = sPfx & "vbKeyRButton":               y(1) = 2
            X(2) = sPfx & "vbKeyCancel":                y(2) = 3
            X(3) = sPfx & "vbKeyMButton":               y(3) = 4
            X(4) = sPfx & "vbKeyBack":                  y(4) = 8
            X(5) = sPfx & "vbKeyTab":                   y(5) = 9
            X(6) = sPfx & "vbKeyClear":                 y(6) = 12
            X(7) = sPfx & "vbKeyReturn":                y(7) = 13
            X(8) = sPfx & "vbKeyShift":                 y(8) = 16
            X(9) = sPfx & "vbKeyControl":               y(9) = 17
            X(10) = sPfx & "vbKeyMenu":                 y(10) = 18
            X(11) = sPfx & "vbKeyPause":                y(11) = 19
            X(12) = sPfx & "vbKeyCapital":              y(12) = 20
            X(13) = sPfx & "vbKeyEscape":               y(13) = 27
            X(14) = sPfx & "vbKeySpace":                y(14) = 32
            X(15) = sPfx & "vbKeyPageUp":               y(15) = 33
            X(16) = sPfx & "vbKeyPageDown":             y(16) = 34
            X(17) = sPfx & "vbKeyEnd":                  y(17) = 35
            X(18) = sPfx & "vbKeyHome":                 y(18) = 36
            X(19) = sPfx & "vbKeyLeft":                 y(19) = 37
            X(20) = sPfx & "vbKeyUp":                   y(20) = 38
            X(21) = sPfx & "vbKeyRight":                y(21) = 39
            X(22) = sPfx & "vbKeyDown":                 y(22) = 40
            X(23) = sPfx & "vbKeySelect":               y(23) = 41
            X(24) = sPfx & "vbKeyPrint":                y(24) = 42
            X(25) = sPfx & "vbKeyExecute":              y(25) = 43
            X(26) = sPfx & "vbKeySnapshot":             y(26) = 44
            X(27) = sPfx & "vbKeyInsert":               y(27) = 45
            X(28) = sPfx & "vbKeyDelete":               y(28) = 46
            X(29) = sPfx & "vbKeyHelp":                 y(29) = 47
            X(30) = sPfx & "vbKeyNumlock":              y(30) = 144
            X(31) = sPfx & "vbKeyA":                    y(31) = 65
            X(32) = sPfx & "vbKeyB":                    y(32) = 66
            X(33) = sPfx & "vbKeyC":                    y(33) = 67
            X(34) = sPfx & "vbKeyD":                    y(34) = 68
            X(35) = sPfx & "vbKeyE":                    y(35) = 69
            X(36) = sPfx & "vbKeyF":                    y(36) = 70
            X(37) = sPfx & "vbKeyG":                    y(37) = 71
            X(38) = sPfx & "vbKeyH":                    y(38) = 72
            X(39) = sPfx & "vbKeyI":                    y(39) = 73
            X(40) = sPfx & "vbKeyJ":                    y(40) = 74
            X(41) = sPfx & "vbKeyK":                    y(41) = 75
            X(42) = sPfx & "vbKeyL":                    y(42) = 76
            X(43) = sPfx & "vbKeyM":                    y(43) = 77
            X(44) = sPfx & "vbKeyN":                    y(44) = 78
            X(45) = sPfx & "vbKeyO":                    y(45) = 79
            X(46) = sPfx & "vbKeyP":                    y(46) = 80
            X(47) = sPfx & "vbKeyQ":                    y(47) = 81
            X(48) = sPfx & "vbKeyR":                    y(48) = 82
            X(49) = sPfx & "vbKeyS":                    y(49) = 83
            X(50) = sPfx & "vbKeyT":                    y(50) = 84
            X(51) = sPfx & "vbKeyU":                    y(51) = 85
            X(52) = sPfx & "vbKeyV":                    y(52) = 86
            X(53) = sPfx & "vbKeyW":                    y(53) = 87
            X(54) = sPfx & "vbKeyX":                    y(54) = 88
            X(55) = sPfx & "vbKeyY":                    y(55) = 89
            X(56) = sPfx & "vbKeyZ":                    y(56) = 90
            X(57) = sPfx & "vbKey0":                    y(57) = 48
            X(58) = sPfx & "vbKey1":                    y(58) = 49
            X(59) = sPfx & "vbKey2":                    y(59) = 50
            X(60) = sPfx & "vbKey3":                    y(60) = 51
            X(61) = sPfx & "vbKey4":                    y(61) = 52
            X(62) = sPfx & "vbKey5":                    y(62) = 53
            X(63) = sPfx & "vbKey6":                    y(63) = 54
            X(64) = sPfx & "vbKey7":                    y(64) = 55
            X(65) = sPfx & "vbKey8":                    y(65) = 56
            X(66) = sPfx & "vbKey9":                    y(66) = 57
            X(67) = sPfx & "vbKeyNumpad0":              y(67) = 96
            X(68) = sPfx & "vbKeyNumpad1":              y(68) = 97
            X(69) = sPfx & "vbKeyNumpad2":              y(69) = 98
            X(70) = sPfx & "vbKeyNumpad3":              y(70) = 99
            X(71) = sPfx & "vbKeyNumpad4":              y(71) = 100
            X(72) = sPfx & "vbKeyNumpad5":              y(72) = 101
            X(73) = sPfx & "vbKeyNumpad6":              y(73) = 102
            X(74) = sPfx & "vbKeyNumpad7":              y(74) = 103
            X(75) = sPfx & "vbKeyNumpad8":              y(75) = 104
            X(76) = sPfx & "vbKeyNumpad9":              y(76) = 105
            X(77) = sPfx & "vbKeyMultiply":             y(77) = 106
            X(78) = sPfx & "vbKeyAdd":                  y(78) = 107
            X(79) = sPfx & "vbKeySeparator":            y(79) = 108
            X(80) = sPfx & "vbKeySubtract":             y(80) = 109
            X(81) = sPfx & "vbKeyDecimal":              y(81) = 110
            X(82) = sPfx & "vbKeyDivide":               y(82) = 111
            X(83) = sPfx & "vbKeyF1":                   y(83) = 112
            X(84) = sPfx & "vbKeyF2":                   y(84) = 113
            X(85) = sPfx & "vbKeyF3":                   y(85) = 114
            X(86) = sPfx & "vbKeyF4":                   y(86) = 115
            X(87) = sPfx & "vbKeyF5":                   y(87) = 116
            X(88) = sPfx & "vbKeyF6":                   y(88) = 117
            X(89) = sPfx & "vbKeyF7":                   y(89) = 118
            X(90) = sPfx & "vbKeyF8":                   y(90) = 119
            X(91) = sPfx & "vbKeyF9":                   y(91) = 120
            X(92) = sPfx & "vbKeyF10":                  y(92) = 121
            X(93) = sPfx & "vbKeyF11":                  y(93) = 122
            X(94) = sPfx & "vbKeyF12":                  y(94) = 123
            X(95) = sPfx & "vbKeyF13":                  y(95) = 124
            X(96) = sPfx & "vbKeyF14":                  y(96) = 125
            X(97) = sPfx & "vbKeyF15":                  y(97) = 126
            X(98) = sPfx & "vbKeyF16":                  y(98) = 127
            
        Case ChrW(&H25E5) & " " & "ColorConstants"
            ReDim X(7):                                 ReDim y(7)
            X(0) = sPfx & "vbBlack":                    y(0) = 0
            X(1) = sPfx & "vbRed":                      y(1) = 255
            X(2) = sPfx & "vbGreen":                    y(2) = 65280
            X(3) = sPfx & "vbYellow":                   y(3) = 65535
            X(4) = sPfx & "vbBlue":                     y(4) = 16711680
            X(5) = sPfx & "vbMagenta":                  y(5) = 16711935
            X(6) = sPfx & "vbCyan":                     y(6) = 16776960
            X(7) = sPfx & "vbWhite":                    y(7) = 16777215

        Case ChrW(&H25E5) & " " & "SystemColorConstants"
            ReDim X(28):                                ReDim y(28)
            X(0) = sPfx & "vbScrollBars":               y(0) = -2147483648#
            X(1) = sPfx & "vbDesktop":                  y(1) = -2147483647
            X(2) = sPfx & "vbActiveTitleBar":           y(2) = -2147483646
            X(3) = "vbInactiveTitleBar":                y(3) = -2147483645
            X(4) = sPfx & "vbMenuBar":                  y(4) = -2147483644
            X(5) = sPfx & "vbWindowBackground":         y(5) = -2147483643
            X(6) = sPfx & "vbWindowFrame":              y(6) = -2147483642
            X(7) = sPfx & "vbMenuText":                 y(7) = -2147483641
            X(8) = sPfx & "vbWindowText":               y(8) = -2147483640
            X(9) = sPfx & "vbTitleBarText":             y(9) = -2147483639
            X(10) = sPfx & "vbActiveBorder":            y(10) = -2147483638
            X(11) = sPfx & "vbInactiveBorder":          y(11) = -2147483637
            X(12) = sPfx & "vbApplicationWorkspace":    y(12) = -2147483636
            X(13) = sPfx & "vbHighlight":               y(13) = -2147483635
            X(14) = sPfx & "vbHighlightText":           y(14) = -2147483634
            X(15) = sPfx & "vbButtonFace":              y(15) = -2147483633
            X(16) = sPfx & "vbButtonShadow":            y(16) = -2147483632
            X(17) = sPfx & "vbGrayText":                y(17) = -2147483631
            X(18) = sPfx & "vbButtonText":              y(18) = -2147483630
            X(19) = sPfx & "vbInactiveCaptionText":     y(19) = -2147483629
            X(20) = sPfx & "vb3DHighlight":             y(20) = -2147483628
            X(21) = sPfx & "vb3DFace":                  y(21) = -2147483633
            X(22) = sPfx & "vbMsgBox":                  y(22) = -2147483625
            X(23) = sPfx & "vbMsgBoxText":              y(23) = -2147483624
            X(24) = sPfx & "vb3DShadow":                y(24) = -2147483632
            X(25) = sPfx & "vb3DDKShadow":              y(25) = -2147483627
            X(26) = sPfx & "vb3DLight":                 y(26) = -2147483626
            X(27) = sPfx & "vbInfoText":                y(27) = -2147483625
            X(28) = sPfx & "vbInfoBackground":          y(28) = -2147483624
    End Select

    BuildSpecailEnumValues.Caption = X:                 BuildSpecailEnumValues.Value = y
End Function

Function GetModulesBaseNamesFromCurrentProcess() As String()

    Const MAX_PATH = 1024&, MAX_NUM_OF_MODULES = 1024&, HANDLE_SIZE = PTR_LEN
    Dim hModuleHandles(MAX_NUM_OF_MODULES) As LongPtr
    Dim hProc As LongPtr
    Dim sModName   As String
    Dim sModBaseName  As String
    Dim sModPath      As String
    Dim tModInfo     As MODULEINFO
    Dim lBytesNeeded As Long, lModCount As Long, i As Long, lStrLen As Long
    
    hProc = GetCurrentProcess
    If EnumProcessModules(hProc, hModuleHandles(0&), (MAX_NUM_OF_MODULES * HANDLE_SIZE), lBytesNeeded) = False Then
        Debug.Print "EnumProcessModules failed"
        Exit Function
    End If
    lModCount = lBytesNeeded \ HANDLE_SIZE
    ReDim sModulesArray(lModCount) As String
    For i = 0& To lModCount - 1&
        If hModuleHandles(i) = 0& Then
            GoTo skipModule
        End If
        If GetModuleInformation(hProc, hModuleHandles(i), tModInfo, lBytesNeeded) = 0& Then
            GoTo skipModule
        End If
        sModName = Space(MAX_PATH + 1&)
        lStrLen = GetModuleFileNameExW(hProc, hModuleHandles(i), StrPtr(sModName), Len(sModName))
        sModPath = Mid(sModName, 1&, lStrLen)
        lStrLen = GetModuleBaseNameW(hProc, hModuleHandles(i), StrPtr(sModName), Len(sModName))
        sModBaseName = Mid(sModName, 1&, lStrLen)
        sModulesArray(i) = sModBaseName
skipModule:
    Next i
    GetModulesBaseNamesFromCurrentProcess = sModulesArray
    Erase hModuleHandles
    Call CloseHandle(hProc)

End Function

Function ModuleBaseNameToFullPath(ByVal BaseName As String) As String
    ModuleBaseNameToFullPath = ModuleFileName(BaseName)
End Function


' ______________________________________ PRIVATE SUBS _______________________________________________

Private Function InterFacesFromClass(tClass As INTERFACE_INFO) As INTERFACE_INFO()

    Const S_OK = 0&, CC_STDCALL = 4&, MEMBERID_NIL = -1&
    Dim pRefType As LongPtr, pClasstypeInfo As LongPtr, farPtr As LongPtr, psGUID As LongPtr
    Dim tTYPEATTR As TYPEATTR, tInterfaceInfo As INTERFACE_INFO
    Dim i As Long, lRet As Long, lInterfaceCount As Long
    Dim sInterfaceName As String

    lInterfaceCount = tClass.InterfacesCount
    ReDim ar(lInterfaceCount - 1&) As INTERFACE_INFO
    With tClass
        For i = 0& To .InterfacesCount - 1&
            lRet = vtblCall(.ptr, 8& * PTR_LEN, vbLong, CC_STDCALL, i, VarPtr(pRefType))  'ITypeInfo::GetRefTypeOfImplType
            If lRet <> S_OK Then
                MsgBox "Unable to retrieve the type description of the implemented interface type.": Exit Function
            End If
            lRet = vtblCall(.ptr, 14& * PTR_LEN, vbLong, CC_STDCALL, pRefType, VarPtr(pClasstypeInfo))  'ITypeInfo::GetRefTypeInfo
            If lRet <> S_OK Then
                MsgBox "Unable to retrieve the referenced type descriptions.": Exit Function
            End If
            lRet = vtblCall(pClasstypeInfo, 12& * PTR_LEN, vbLong, CC_STDCALL, MEMBERID_NIL, VarPtr(sInterfaceName), NULL_PTR, NULL_PTR, NULL_PTR) 'ITypeInfo::GetDocumentation
            If lRet <> S_OK Then
                MsgBox "Unable to retrieve the documentation string.": Exit Function
            End If
            lRet = vtblCall(pClasstypeInfo, 3& * PTR_LEN, vbLong, CC_STDCALL, VarPtr(farPtr))  'ITypeInfo::GetTypeAttr
            If lRet <> S_OK Then
                MsgBox "Unable to retrieve a TYPEATTR structure that contains the attributes of the type description"
                Exit Function
            End If
            Call CopyMemory(tTYPEATTR, ByVal farPtr, LenB(tTYPEATTR))
            lRet = vtblCall(pClasstypeInfo, 19& * PTR_LEN, vbEmpty, CC_STDCALL, farPtr) 'ITypeInfo::ReleaseTypeAttr
            Call StringFromIID(tTYPEATTR.aGUID, VarPtr(psGUID))
            With tInterfaceInfo
                .ptr = pClasstypeInfo
                .GUID = GetStrFromPtrW(psGUID)
                .Name = sInterfaceName
                .MembersCount = tTYPEATTR.cFuncs
                .wMajorVerNum = tTYPEATTR.wMajorVerNum
                .wMinorVerNum = tTYPEATTR.wMinorVerNum
            End With
            ar(i) = tInterfaceInfo
        Next i
    End With
    InterFacesFromClass = ar

End Function

Private Function vtblCall( _
    ByVal InterfacePointer As LongPtr, _
    ByVal VTableOffset As Long, _
    ByVal FunctionReturnType As Long, _
    ByVal CallConvention As Long, _
    ParamArray FunctionParameters() As Variant _
) As Variant
        
    Dim vParamPtr() As LongPtr

    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 BuildClassInfoString(INFO As INTERFACE_INFO, bShowUnkDisp As Boolean) As TEXT_STRUCT
    Dim tString As TEXT_STRUCT
    With tString
        .Caption = _
            "[Class Name:] " & vbLf & _
            "[Members Count:] " & vbLf & _
            "[GUID:] " & vbLf & _
            "[LCID:] " & vbLf & _
            "[PTR:] "
            .Value = INFO.Name & vbLf & _
            IIf(bShowUnkDisp, INFO.MembersCount, INFO.MembersCount - 7&) & vbLf & _
            INFO.GUID & vbLf & _
            INFO.lcid & vbLf & _
            INFO.ptr
    End With
    BuildClassInfoString = tString
End Function

Private Function ReturnType(ByVal RetType As VarEnum) As String
    Dim sRetVarType As String
    Select Case RetType
        Case VT_NULL:                sRetVarType = "Long"
        Case VT_I2:                  sRetVarType = "Integer"
        Case VT_I4:                  sRetVarType = "Long"
        Case VT_R4:                  sRetVarType = "Single"
        Case VT_R8:                  sRetVarType = "Double"
        Case VT_CY:                  sRetVarType = "Currency"
        Case VT_DATE:                sRetVarType = "Date"
        Case VT_BSTR:                sRetVarType = "BSTR(String)"
        Case VT_DISPATCH, VT_PTR:    sRetVarType = "Object"
        Case VT_ERROR:               sRetVarType = "SCODE"
        Case VT_BOOL:                sRetVarType = "Boolean"
        Case VT_VARIANT:             sRetVarType = "VARIANT"
        Case VT_UNKNOWN:             sRetVarType = "IUnknown*"
        Case VT_UI1:                 sRetVarType = "Byte"
        Case VT_DECIMAL:             sRetVarType = "Decimal"
        Case VT_I1:                  sRetVarType = "Char"
        Case VT_UI2:                 sRetVarType = "USHORT"
        Case VT_UI4:                 sRetVarType = "ULONG"
        Case VT_I8:                  sRetVarType = "LongLong"
        Case VT_UI8:                 sRetVarType = "unsigned __int64"
        Case VT_INT:                 sRetVarType = "int"
        Case VT_UINT:                sRetVarType = "UINT"
        Case VT_HRESULT:             sRetVarType = "HRESULT"
        Case VT_VOID:                sRetVarType = "VOID"
        Case VT_LPSTR:               sRetVarType = "char*"
        Case VT_LPWSTR:              sRetVarType = "wchar_t*"
        Case Else:                   sRetVarType = "ANY"
    End Select
    ReturnType = sRetVarType
End Function

Private Function GetStrFromPtrW(ByVal lpString As LongPtr) As String
    Call SysReAllocString(VarPtr(GetStrFromPtrW), lpString)
    Call CoTaskMemFree(lpString)
End Function

Private Function ModuleFileName(ByVal ModuleName As String) As String
    Const MAX_PATH = 1024&
    Dim sBuffer As String, lRet As Long, hMod As LongPtr
    hMod = GetModuleHandleW(StrPtr(ModuleName))
        sBuffer = Space(MAX_PATH)
        lRet = GetModuleFileNameW(hMod, StrPtr(sBuffer), Len(sBuffer))
        ModuleFileName = Left(sBuffer, lRet)
End Function


2- UserForm Browser Code:
VBA Code:
Option Explicit

Private ElementType As SEARCH_TARGET
Private sCurLib As String

Private Sub UserForm_Initialize()
    Call SetUpControls
    ComboLibs.List = GetModulesBaseNamesFromCurrentProcess
    ComboLibs.ListIndex = 0&
    If RetrieveLibInfo(ModuleBaseNameToFullPath(ComboLibs.ListIndex)) Then
        ListClasses.List = tArrays.arrNames
    End If
    ComboRefs.List = GetVBEReferencesList
    ComboRefs.ListIndex = 0&
    If ListClasses.ListIndex = -1& And ListClasses.ListCount Then
        ListClasses.SetFocus
        ListClasses.ListIndex = 0&
    End If
End Sub

Private Sub UserForm_Terminate()
    Call EraseArrays
End Sub

Private Sub SetUpControls()
    txtCls.Text = ChrW(&H25A0)
    txtMod.Text = ChrW(&H25E5)
    txtEnum.Text = ChrW(&H25CD)
    txtProp.Text = ChrW(&H25A6)
    txtMethod.Text = ChrW(&H25B1)
    txtEvent.Text = ChrW(&H2944)
    txtConst.Text = ChrW(&H2022)
    TxtValues.MultiLine = True
    TxtCaptions.MultiLine = True
    ListClasses.Font.Size = 10&
    ListMembers.Font.Size = 10&
    ComboLibs.Font.Size = 10&
    ComboRefs.Font.Size = 10&
    chkLet.Value = True
    chkGet.Value = True
    chkSet.Value = True
    chkMethod.Value = True
End Sub

Private Sub ClearControls()
    ListClasses.Clear
    ListMembers.Clear
    TxtValues.Text = ""
    TxtCaptions.Text = ""
    Me.lblViweLib.Caption = ""
    Me.lblGUID.Caption = ""
End Sub

Private Sub ComboRefs_Change()
    Call ClearControls
    If RetrieveLibInfo(RefLibNameToFullPath(Me.ComboRefs.Value)) = False Then
        Exit Sub
    End If
    If Not Not tArrays.arrNames Then
        ListClasses.List = tArrays.arrNames
    End If
    sCurLib = RefLibNameToFullPath(ComboRefs.Value)
    lblViweLib.Caption = "- Viewing Library:   [" & sCurLib & "]"
    lblGUID.Caption = "- GUID:" & Space(18&) & "[" & GUIDFromLib(sCurLib) & "]"
End Sub

Private Sub ComboLibs_Change()
    Call ClearControls
    If RetrieveLibInfo(ModuleBaseNameToFullPath(ComboLibs.Value)) = False Then
        Exit Sub
    End If
    If Not Not tArrays.arrNames Then
        ListClasses.List = tArrays.arrNames
    End If
    sCurLib = ModuleBaseNameToFullPath(ComboLibs.Value)
    lblViweLib.Caption = "- Viewing Library:   [" & sCurLib & "]"
    lblGUID.Caption = "- GUID:" & Space(18&) & "[" & GUIDFromLib(sCurLib) & "]"
End Sub

Private Sub ListMembers_Change()
    If ListMembers.ListIndex <> -1& Then
        If ElementType <> Enum_ Then
            Me.TxtValues = BuildFuncInfoString(tArrays.arrFuncPtrs(ListMembers.ListIndex)).Value
            Me.TxtCaptions = BuildFuncInfoString(tArrays.arrFuncPtrs(ListMembers.ListIndex)).Caption
        Else
        If GetSpecialEnum(ListClasses.Value) Then
            TxtCaptions.Text = _
                "[Const Name:]" & vbLf & _
                "[Value:]"
            TxtValues.Text = ListMembers.Value & vbLf & _
            BuildSpecailEnumValues(ListClasses.Value).Value(ListMembers.ListIndex)
            Exit Sub
        End If
            TxtValues = BuildEnumInfoString(tArrays.arrEnumPtrs(ListMembers.ListIndex)).Value
            TxtCaptions = BuildEnumInfoString(tArrays.arrEnumPtrs(ListMembers.ListIndex)).Caption
        End If
    End If
End Sub

Private Sub ListClasses_Change()

    #If Win64 Then
        Dim lPtr As LongLong
    #Else
        Dim lPtr As Long
    #End If
    Dim Funcs() As FUNC_INFO, Enums() As ENUM_VALS
    Dim sClassNames As String, sDecoration As String, i As Long
    
    If ListClasses.ListIndex = -1& Then Exit Sub
    ListMembers.Clear

    If GetSpecialEnum(ListClasses.Value) Then
        ElementType = Enum_
        ListMembers.List = BuildSpecailEnumValues(ListClasses.Value, ChrW(&H2022) & " ").Caption
        Exit Sub
    End If
    
    With tArrays
        Erase .arrFuncPtrs:   Erase .arrEnumPtrs
        ElementType = .arrTypes(ListClasses.ListIndex)
        sClassNames = .arrNames(ListClasses.ListIndex)
        lPtr = .arrPtrs(ListClasses.ListIndex)
    
        'retrieve all members\funcs.
        Funcs = GetFuncs( _
            lPtr, _
            Abs(CLng(chkLet.Value)) * VbLet + _
            Abs(CLng(chkGet.Value)) * VbGet + _
            Abs(CLng(chkSet.Value)) * VbSet + _
            Abs(CLng(chkMethod.Value)) * VbMethod, _
            chkIUnkDisp.Value _
        )
    
        'add class members to listbox.
        If Not Not Funcs Then
            For i = LBound(Funcs) To UBound(Funcs)
                ReDim Preserve .arrFuncPtrs(i)
                .arrFuncPtrs(i) = Funcs(i)
                Select Case Funcs(i).INVOKEKIND
                    Case Is = "VbGet", "VbLet", "VbSet"
                        sDecoration = ChrW(&H25A6) & " "
                    Case Is = "VbMethod"
                        sDecoration = ChrW(&H25B1) & " "
                End Select
                ListMembers.AddItem sDecoration & Funcs(i).Name
            Next i
        End If
    
        'add enums to listbox.
        If Not Funcs Then
                If .arrTypes(ListClasses.ListIndex) = Enum_ Then
                    Enums = MembersFromEnum(lPtr)
                    If Not Not Enums Then
                        For i = LBound(Enums) To UBound(Enums)
                            ReDim Preserve .arrEnumPtrs(i)
                            .arrEnumPtrs(i) = Enums(i)
                            ListMembers.AddItem ChrW(&H2022) & " " & Enums(i).Name
                        Next i
                    End If
                End If
        End If
    
        'show info about the selected item.
        TxtCaptions.Text = .arrOtherInfo1(ListClasses.ListIndex).Caption
        If UserForm1.chkIUnkDisp.Value Or .arrTypes(ListClasses.ListIndex) = Enum_ Then
            TxtValues.Text = .arrOtherInfo2(ListClasses.ListIndex).Value
        Else
            TxtValues.Text = .arrOtherInfo1(ListClasses.ListIndex).Value
        End If
    End With

End Sub

Private Sub btnExportToSheet_Click()
    MsgBox "not in use yet."
End Sub

Any feedback, suggestions and bug-reports will be most welcome.
 
Upvote 0

Forum statistics

Threads
1,215,069
Messages
6,122,954
Members
449,095
Latest member
nmaske

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