Getting the list of all Enums in TypeLibs via code (Like the Object Browser)

[Jaafar Tribak]

Hi all,

This is a similar concept to the topic of this thread. Only this time, instead of retrieving Properties and Methods of Objects, the code now retrieves the names and values of all the native ENUM constants contained in typelibs.

No extrenal libraries required. the functions in the code use plain vba code and a few window api calls.

The code offers 3 different ways for getting the entire list of Enums contained in the target library :
GetTypeLibEnumsByGUID : Pass the tlb GUID, VerMajor and VerMinor
GetTypeLibEnumsByFilePath : Pass the tlb full PathName
GetTypeLibEnumsByObject : Pass an instance of an object

Use whichever method you find easier. You should be able to apply the above functions to get the list of enums in various tlbs, olbs, exes, dlls not just the enums in the excel library.

You could easily get the tlb GUIDs using the vbe extensibitlity library or a tlb viewer such as OLEVIEW.EXE

In the case of my excel 2016 where I wrote and tested the code, the GUID for excel is : ("{00020813-0000-0000-C000-000000000046}", 1, 9)

Workbook Example:
EnumsList.xlsm

1- API code in a Standard Module:

Option Explicit

Public Type Enums
    EnumName As String
    EnumValue As Long
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
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 LARGE_INT
    LowPart As Long
    HighPart As Long
End Type
 
Private Type DUMMYUNIONNAME_TYPE
    oInst As Long
    #If Win64 Then
        lpvarValue As LongLong
    #Else
        lpvarValue As Long
    #End If
End Type

Private Type VARDESC
    memid As Long
    #If Win64 Then
        lpstrSchema As LongLong
        DUMMYUNIONNAME As LongLong
    #Else
        lpstrSchema As Long
        DUMMYUNIONNAME As Long
    #End If
    elemdescVar As Long
    wVarFlags As Long
    varkind As Long
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)
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As Long
    Private Declare PtrSafe Function LoadTypeLib Lib "oleaut32" (ByVal szFile As LongPtr, pptlib As LongPtr) As Long
    Private Declare PtrSafe Function LoadRegTypeLib Lib "oleaut32" (ByVal rguid As LongPtr, ByVal wVerMajor As Integer, ByVal wVerMinor As Integer, ByVal LCID As Long, ByVal pptlib As LongPtr) 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)
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, ByVal lpiid As Long) As Long
    Private Declare Function LoadTypeLib Lib "oleaut32" (ByVal szFile As Long, pptlib As Long) As Long
    Private Declare Function LoadRegTypeLib Lib "oleaut32" (ByVal rguid As Long, ByVal wVerMajor As Integer, ByVal wVerMinor As Integer, ByVal LCID As Long, ByVal pptlib As Long) As Long
#End If



Public Function GetTypeLibEnumsByGUID( _
    ByVal sGUID As String, _
    ByVal VerMajor As Integer, _
    ByVal VerMinor As Integer _
) As Enums()

    #If Win64 Then
        Const PTR_SIZE As Long = 8

        Dim pDispTypeLib As LongLong
        Dim ppTypeAttr As LongLong
        Dim pVARDESC  As LongLong
        Dim pITypeInfo As LongLong
    #Else
        Const PTR_SIZE As Long = 4

        Dim pDispTypeLib As Long
        Dim ppTypeAttr As Long
        Dim pVARDESC  As Long
        Dim pITypeInfo As Long
    #End If

    Const CC_STDCALL = 4
    Const TKIND_ENUM = 0
 
    Dim tRet() As Enums
    Dim tTYPEATTR As TYPEATTR, tVARDESC As VARDESC
    Dim tDUMMYUNIONNAME As DUMMYUNIONNAME_TYPE, tLRG_INT As LARGE_INT
    Dim BstrName As String, pcNames As Long
    Dim lTypeInfoCount As Long, index As Long, i As Long, pTKind As Long
    Dim pIndex As Long, lRet As Long, j As Long
    Dim tGUID(0 To 3) As Long
 
 
    lRet = IIDFromString(StrPtr(sGUID), VarPtr(tGUID(0)))
 
    Call LoadRegTypeLib(VarPtr(tGUID(0)), VerMajor, VerMinor, 0, VarPtr(pDispTypeLib))
    If pDispTypeLib = 0 Then MsgBox "Loading The TypeLib failed.", , "Error": Exit Function
 
    lTypeInfoCount = vtblCall(pDispTypeLib, 3 * PTR_SIZE, vbLong, CC_STDCALL) 'IDispatch::GetTypeInfoCount
    If lTypeInfoCount = 0 Then MsgBox "IDispatch::GetTypeInfoCount failed.", , "Error": Exit Function
 
    For index = 0 To lTypeInfoCount - 1
 
        lRet = vtblCall(pDispTypeLib, 5 * PTR_SIZE, vbLong, CC_STDCALL, index, VarPtr(pTKind)) 'ITypeLib::GetTypeInfoType
        If lRet Then MsgBox "ITypeLib::GetTypeInfoType failed.", , "Error": Exit Function
   
        If pTKind = TKIND_ENUM Then
   
            Call vtblCall(pDispTypeLib, 4 * PTR_SIZE, vbLong, CC_STDCALL, index, VarPtr(pITypeInfo)) 'IDispatch::GetTypeInfo
            If pITypeInfo = 0 Then MsgBox "IDispatch::GetTypeInfo failed.", , "Error": Exit Function
       
            Call vtblCall(pITypeInfo, 3 * PTR_SIZE, vbLong, CC_STDCALL, VarPtr(ppTypeAttr)) 'ITypeInfo::GetTypeAttr
            If ppTypeAttr = 0 Then MsgBox "ITypeInfo::GetTypeAttr failed.", , "Error": Exit Function
       
            Call CopyMemory(ByVal VarPtr(tTYPEATTR), ByVal ppTypeAttr, LenB(tTYPEATTR))
       
            For i = 0 To tTYPEATTR.cVars - 1
       
                Call vtblCall(pITypeInfo, 6 * PTR_SIZE, vbLong, CC_STDCALL, i, VarPtr(pVARDESC)) 'ITypeInfo::GetVarDesc
                If pVARDESC = 0 Then MsgBox "ITypeInfo::GetVarDesc failed.", , "Error": Exit Function
           
                Call CopyMemory(ByVal VarPtr(tVARDESC), ByVal pVARDESC, LenB(tVARDESC))
           
                Call vtblCall(pITypeInfo, 7 * 8, vbLong, CC_STDCALL, tVARDESC.memid, VarPtr(BstrName), tTYPEATTR.cVars, VarPtr(pcNames)) 'ITypeInfo::GetNames
                If pcNames = 0 Then MsgBox "ITypeInfo::GetNames failed.", , "Error": Exit Function
           
                Call CopyMemory(tDUMMYUNIONNAME, ByVal tVARDESC.DUMMYUNIONNAME, Len(tDUMMYUNIONNAME))
           
                Call CopyMemory(ByVal tLRG_INT, tDUMMYUNIONNAME.lpvarValue, PTR_SIZE)
           
                ReDim Preserve tRet(j) As Enums
                tRet(j).EnumName = BstrName
                tRet(j).EnumValue = tLRG_INT.LowPart
                j = j + 1
           
            Next i
   
        End If
 
    Next index
 
    GetTypeLibEnumsByGUID = tRet

End Function


Public Function GetTypeLibEnumsByFilePath(ByVal FilePathName As String) As Enums()

    #If Win64 Then
        Const PTR_SIZE As Long = 8

        Dim pDispTypeLib As LongLong
        Dim ppTypeAttr As LongLong
        Dim pVARDESC  As LongLong
        Dim pITypeInfo As LongLong
    #Else
        Const PTR_SIZE As Long = 4

        Dim pDispTypeLib As Long
        Dim ppTypeAttr As Long
        Dim pVARDESC  As Long
        Dim pITypeInfo As Long
    #End If

    Const CC_STDCALL = 4
    Const TKIND_ENUM = 0

    Dim tRet() As Enums
    Dim tTYPEATTR As TYPEATTR, tVARDESC As VARDESC
    Dim tDUMMYUNIONNAME As DUMMYUNIONNAME_TYPE, tLRG_INT As LARGE_INT
    Dim BstrName As String, pcNames As Long
    Dim lTypeInfoCount As Long, index As Long, i As Long, pTKind As Long
    Dim pIndex As Long, lRet As Long, j As Long


    Call LoadTypeLib(StrPtr(FilePathName), pDispTypeLib)
    If pDispTypeLib = 0 Then MsgBox "Loading The TypeLib failed.", , "Error": Exit Function

    lTypeInfoCount = vtblCall(pDispTypeLib, 3 * PTR_SIZE, vbLong, CC_STDCALL) 'IDispatch::GetTypeInfoCount
    If lTypeInfoCount = 0 Then MsgBox "IDispatch::GetTypeInfoCount failed.", , "Error": Exit Function

    For index = 0 To lTypeInfoCount - 1

        lRet = vtblCall(pDispTypeLib, 5 * PTR_SIZE, vbLong, CC_STDCALL, index, VarPtr(pTKind)) 'ITypeLib::GetTypeInfoType
        If lRet Then MsgBox "ITypeLib::GetTypeInfoType failed.", , "Error": Exit Function

        If pTKind = TKIND_ENUM Then

            Call vtblCall(pDispTypeLib, 4 * PTR_SIZE, vbLong, CC_STDCALL, index, VarPtr(pITypeInfo)) 'IDispatch::GetTypeInfo
            If pITypeInfo = 0 Then MsgBox "IDispatch::GetTypeInfo failed.", , "Error": Exit Function

            Call vtblCall(pITypeInfo, 3 * PTR_SIZE, vbLong, CC_STDCALL, VarPtr(ppTypeAttr)) 'ITypeInfo::GetTypeAttr
            If ppTypeAttr = 0 Then MsgBox "ITypeInfo::GetTypeAttr failed.", , "Error": Exit Function

            Call CopyMemory(ByVal VarPtr(tTYPEATTR), ByVal ppTypeAttr, LenB(tTYPEATTR))

            For i = 0 To tTYPEATTR.cVars - 1

                Call vtblCall(pITypeInfo, 6 * PTR_SIZE, vbLong, CC_STDCALL, i, VarPtr(pVARDESC)) 'ITypeInfo::GetVarDesc
                If pVARDESC = 0 Then MsgBox "ITypeInfo::GetVarDesc failed.", , "Error": Exit Function

                Call CopyMemory(ByVal VarPtr(tVARDESC), ByVal pVARDESC, LenB(tVARDESC))

                Call vtblCall(pITypeInfo, 7 * 8, vbLong, CC_STDCALL, tVARDESC.memid, VarPtr(BstrName), tTYPEATTR.cVars, VarPtr(pcNames)) 'ITypeInfo::GetNames
                If pcNames = 0 Then MsgBox "ITypeInfo::GetNames failed.", , "Error": Exit Function

                Call CopyMemory(tDUMMYUNIONNAME, ByVal tVARDESC.DUMMYUNIONNAME, Len(tDUMMYUNIONNAME))

                Call CopyMemory(ByVal tLRG_INT, tDUMMYUNIONNAME.lpvarValue, PTR_SIZE)

                ReDim Preserve tRet(j) As Enums
                tRet(j).EnumName = BstrName
                tRet(j).EnumValue = tLRG_INT.LowPart
                j = j + 1

            Next i

        End If

    Next index

    GetTypeLibEnumsByFilePath = tRet

End Function


Public Function GetTypeLibEnumsByObject(ByVal oObj As Object) As Enums()

    #If Win64 Then
        Const PTR_SIZE = 8

        Dim pObj As LongLong
        Dim pTypeInfo As LongLong
        Dim ppTypeAttr As LongLong
        Dim pVARDESC  As LongLong
        Dim pITypeInfo As LongLong
        Dim pDispTypeLib As LongLong
    #Else
        Const PTR_SIZE = 4

        Dim pObj As Long
        Dim pTypeInfo As Long
        Dim ppTypeAttr As Long
        Dim pVARDESC  As Long
        Dim pITypeInfo As Long
        Dim pDispTypeLib As Long
    #End If

    Const CC_STDCALL = 4
    Const TKIND_ENUM = 0

    Dim tRet() As Enums
    Dim tTYPEATTR As TYPEATTR, tVARDESC As VARDESC
    Dim tDUMMYUNIONNAME As DUMMYUNIONNAME_TYPE, tLRG_INT As LARGE_INT
    Dim BstrName As String, pcNames As Long
    Dim lTypeInfoCount As Long, index As Long, i As Long, pTKind As Long
    Dim pIndex As Long, lRet As Long, j As Long


    pObj = ObjPtr(oObj)

    Call vtblCall(pObj, 4 * PTR_SIZE, vbLong, CC_STDCALL, 0&, 0&, VarPtr(pTypeInfo)) 'IDispatch::GetTypeInfo
    If pTypeInfo = 0 Then MsgBox "IDispatch::GetTypeInfo failed.", , "Error": Exit Function

    Call vtblCall(pTypeInfo, 18 * PTR_SIZE, vbEmpty, CC_STDCALL, VarPtr(pDispTypeLib), VarPtr(pIndex)) 'ITypeInfo::GetContainingTypeLib
    If pDispTypeLib = 0 Then MsgBox "ITypeInfo::GetContainingTypeLib failed.", , "Error": Exit Function

    lTypeInfoCount = vtblCall(pDispTypeLib, 3 * PTR_SIZE, vbLong, CC_STDCALL) 'IDispatch::GetTypeInfoCount
    If lTypeInfoCount = 0 Then MsgBox "IDispatch::GetTypeInfoCount failed.", , "Error": Exit Function

    For index = 0 To lTypeInfoCount - 1

        lRet = vtblCall(pDispTypeLib, 5 * PTR_SIZE, vbLong, CC_STDCALL, index, VarPtr(pTKind)) 'ITypeLib::GetTypeInfoType
        If lRet Then MsgBox "ITypeLib::GetTypeInfoType failed.", , "Error": Exit Function

        If pTKind = TKIND_ENUM Then

            Call vtblCall(pDispTypeLib, 4 * PTR_SIZE, vbLong, CC_STDCALL, index, VarPtr(pITypeInfo)) 'IDispatch::GetTypeInfo
            If pITypeInfo = 0 Then MsgBox "IDispatch::GetTypeInfo failed.", , "Error": Exit Function

            Call vtblCall(pITypeInfo, 3 * PTR_SIZE, vbLong, CC_STDCALL, VarPtr(ppTypeAttr)) 'ITypeInfo::GetTypeAttr
            If ppTypeAttr = 0 Then MsgBox "ITypeInfo::GetTypeAttr failed.", , "Error": Exit Function

            Call CopyMemory(ByVal VarPtr(tTYPEATTR), ByVal ppTypeAttr, LenB(tTYPEATTR))

            Call vtblCall(pTypeInfo, 19 * PTR_SIZE, vbEmpty, CC_STDCALL, ppTypeAttr) 'ITypeInfo::ReleaseTypeAttr
       
            For i = 0 To tTYPEATTR.cVars - 1

                Call vtblCall(pITypeInfo, 6 * PTR_SIZE, vbLong, CC_STDCALL, i, VarPtr(pVARDESC)) 'ITypeInfo::GetVarDesc
                If pVARDESC = 0 Then MsgBox "ITypeInfo::GetVarDesc failed.", , "Error": Exit Function

                Call CopyMemory(ByVal VarPtr(tVARDESC), ByVal pVARDESC, LenB(tVARDESC))

                Call vtblCall(pITypeInfo, 7 * PTR_SIZE, vbLong, CC_STDCALL, tVARDESC.memid, VarPtr(BstrName), tTYPEATTR.cVars, VarPtr(pcNames)) 'ITypeInfo::GetNames
                If pcNames = 0 Then MsgBox "ITypeInfo::GetNames failed.", , "Error": Exit Function

                Call CopyMemory(tDUMMYUNIONNAME, ByVal tVARDESC.DUMMYUNIONNAME, Len(tDUMMYUNIONNAME))

                Call CopyMemory(ByVal tLRG_INT, tDUMMYUNIONNAME.lpvarValue, PTR_SIZE)

                ReDim Preserve tRet(j) As Enums
                tRet(j).EnumName = BstrName
                tRet(j).EnumValue = tLRG_INT.LowPart
                j = j + 1

            Next i

        End If

    Next index

    GetTypeLibEnumsByObject = tRet

End Function


'___________________________________________ HELPER ROUTINE _____________________________________________________

#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

2- Testing (As per the workbook example in the above link)

Option Explicit


Sub Test_Lib_By_Object()

    Dim tEnums() As Enums, i As Long
 
    tEnums = GetTypeLibEnumsByObject(Excel.Application)
    With UserForm1
        .Caption = "Test_Lib_By_Object"
        .Label3 = .Label3 & UBound(tEnums) + 1
    End With
 
    With UserForm1.ListBox1
        .ColumnWidths = "150;2"
        For i = LBound(tEnums) To UBound(tEnums)
            .AddItem
            .List(i, 0) = tEnums(i).EnumName
            .List(i, 1) = tEnums(i).EnumValue '& "abcdef"
        Next i
    End With
 
    UserForm1.Show

End Sub


Sub Test_Lib_By_Path()

    Dim tEnums() As Enums, i As Long
 
    tEnums = GetTypeLibEnumsByFilePath(Application.Path & "\Excel.exe")
 
    With UserForm1
        .Caption = "LIB PATH : " & Application.Path & "\Excel.exe"
        .Label3 = .Label3 & UBound(tEnums) + 1
    End With
 
    With UserForm1.ListBox1
        .ColumnWidths = "150;2"
        For i = LBound(tEnums) To UBound(tEnums)
            .AddItem
            .List(i, 0) = tEnums(i).EnumName
            .List(i, 1) = tEnums(i).EnumValue
        Next i
    End With
 
    UserForm1.Show

End Sub


Sub Test_Lib_By_GUID()

    Dim tEnums() As Enums, i As Long
 
    'GUID may vary according to the typelib version.
    tEnums = GetTypeLibEnumsByGUID("{00020813-0000-0000-C000-000000000046}", 1, 9)
 
    With UserForm1
        .Caption = "LIB GUID : " & "{00020813-0000-0000-C000-000000000046}"
        .Label3 = .Label3 & UBound(tEnums) + 1
    End With
 
    With UserForm1.ListBox1
        .ColumnWidths = "150;2"
        For i = LBound(tEnums) To UBound(tEnums)
            .AddItem
            .List(i, 0) = tEnums(i).EnumName
            .List(i, 1) = tEnums(i).EnumValue '& "abcdef"
        Next i
    End With
 
    UserForm1.Show
End Sub

'Other Lib paths examples for testing - Paths woill need to be adjusted according to user settings.
'=================================================================================================
    '"C:\Program Files\Microsoft Office\Office16\excel.exe"
    '"C:\Program Files\Common Files\Microsoft Shared\OFFICE16\MSO.DLL"
    '"C:\Program Files\Microsoft Office\Office16\MSWORD.OLB"
    '"C:\Windows\system32\stdole32.tlb"
    '"C:\Program Files\Common Files\Microsoft Shared\VBA\VBA7.1\vbe7.dll"
    '"C:\Windows\system32\oleacc.dll"
    '"C:\Windows\system32\ieframe.dll"
    '"C:\Windows\system32\taskschd.dll"
    '"C:\Windows\system32\uiautomationcore.dll"
    '"C:\Windows\system32\wshom.ocx"
    '"c:\windows\system32\FM20.dll"

Regards.

 

[Jaafar Tribak]

Board editing time is up so quickly !

Small correction needed- change is in red:

This code line:
Call vtblCall(pITypeInfo, 7 * 8, vbLong, CC_STDCALL, tVARDESC.memid, VarPtr(BstrName), tTYPEATTR.cVars, VarPtr(pcNames)) 'ITypeInfo::GetNames

should be :
Call vtblCall(pITypeInfo, 7 * PTR_SIZE, vbLong, CC_STDCALL, tVARDESC.memid, VarPtr(BstrName), tTYPEATTR.cVars, VarPtr(pcNames)) 'ITypeInfo::GetNames

Workbook updated with this correction change.

 

[audeser]

You are the master of this VBA universe!
Thank you. Comes handy to tackle down the CAD clone constants mess (Autocad vs Zwcad vs Bricscad vs Intellicad). With your other post to browse methods inside objects, I think this will be first ever app that would work with any of them without having to craft special editions for each one.

 

[audeser]

As you have mentioned, GUID could be obtained from VBA code alone, so no need for external tlb viewers.
To get any Library GUID, load on VBProject. Go to menu Tool > References... > add the reference you want to get the GUID, then run procedure

Public Sub sVBE_IDE_Display_GUID_Info()
' PURPOSE: Displays GUID information for each active Object Library reference in the VBA project
    Dim oVBProj As Object 'As VBIDE.vbProject   ' early biding
    Dim oVBRef As Object  'As VBIDE.Reference   ' early biding
   
'if VBproject hostApp is Excel
     Set oVBProj = Excel.ThisWorkbook.vbProject
'    Set oVBProj = Excel.Application.Workbooks("FileName.xlam/xlsm/xls").vbProject   ' if target is in another LOADED file
'if VBproject hostApp is ProgeCAD
'    Set oVBProj = IntelliCAD.Application.VBE.VBProjects.Item("CommonProjects")
'if VBproject hostApp is ZWCAD
'    'Set oVBProj = ZWCAD.VBE.VBProjects.Item("ZWCADProject")
   
    'Loop Through Each Active Reference (Displays in Immediate Window [ctrl + g])
    For Each oVBRef In oVBProj.References
        With oVBRef
            Debug.Print "Reference Name: ", .Name
            'Debug.Print "Path: ", .FullPath
            Debug.Print "GUID: " & .GUID
            'Debug.Print "Version: " & .Major & "." & .Minor
            Debug.Print "-------"
        End With
    Next oVBRef
End Sub

 

[audeser]

Minor and Major version are needed when exploring by GUID, so should uncomment line Debug.Print "Version: " & .Major & "." & .Minor

 

[audeser]

There should be an error Check, to not call the UserForm when no Enums returned. So for all procedures in Test_bas module should include these two lines:

    If Not (Not tEnums) Then  ' add this line
        With UserForm1

And should end with:

        UserForm1.Show
    End If   'Add this line

 

[audeser]

This is my Test_bas module with modifications implemented (some code to export to file), little error checking and some variable declarations to get generalized

Option Explicit

Sub Test_Lib_By_Object()
    Dim tEnums() As Enums, i As Long
    Dim ObjectLib As Object
    Dim hndOut As Integer
   
    Set ObjectLib = Excel.Application
    tEnums() = GetTypeLibEnumsByObject(ObjectLib)
   
    If Not (Not tEnums) Then
        With UserForm1
            .Caption = "Test_Lib_By_Object"
            .Label3 = .Label3 & UBound(tEnums) + 1
        End With
       
hndOut = VBA.FreeFile()
Open VBA.Environ$("UserProfile") & "\Documents\Enums_" & ObjectLib.Name & ".bas" For Output Shared As #hndOut
        With UserForm1.ListBox1
            .ColumnWidths = "150;2"
            For i = LBound(tEnums) To UBound(tEnums)
                .AddItem
                .List(i, 0) = tEnums(i).EnumName
                .List(i, 1) = tEnums(i).EnumValue
Print #hndOut, "Private Const " & tEnums(i).EnumName & " As Long = " & tEnums(i).EnumValue & vbTab & "' " & tEnums(i).EnumName
            Next i
        End With
       
        UserForm1.Show
Close #hndOut
    End If
    Set ObjectLib = Nothing
End Sub

Sub Test_Lib_By_Path()
    Dim tEnums() As Enums, i As Long
    Dim Path As String
    Dim hndOut As Integer
   
' Excel:
'Path = Application.Path & "\Excel.exe"

'Other Lib paths examples for testing - Paths woill need to be adjusted according to user settings.
'=================================================================================================
'    Path = "C:\Program Files\Microsoft Office\Office16\excel.exe"
'    Path = "C:\Program Files\Common Files\Microsoft Shared\OFFICE16\MSO.DLL"
'    Path = "C:\Program Files\Microsoft Office\Office16\MSWORD.OLB"
'    Path = "C:\Windows\system32\stdole32.tlb"
'    Path = "C:\Program Files\Common Files\Microsoft Shared\VBA\VBA7.1\vbe7.dll"
'    Path = "C:\Windows\system32\oleacc.dll"
'    Path = "C:\Windows\system32\ieframe.dll"
'    Path = "C:\Windows\system32\taskschd.dll"
'    Path = "C:\Windows\system32\uiautomationcore.dll"
'    Path = "C:\Windows\system32\wshom.ocx"
'    Path = "c:\windows\system32\FM20.dll"

    tEnums() = GetTypeLibEnumsByFilePath(Path)

    If Not (Not tEnums) Then
        With UserForm1
            .Caption = "LIB PATH : " & Application.Path & "\Excel.exe"
            .Label3 = .Label3 & UBound(tEnums) + 1
        End With
       
hndOut = VBA.FreeFile()
Open VBA.Environ$("UserProfile") & "\Documents\Enums_" & VBA.Mid(Path, VBA.InStrRev(Path, "\") + 1) & ".bas" For Output Shared As #hndOut
        With UserForm1.ListBox1
            .ColumnWidths = "150;2"
            For i = LBound(tEnums) To UBound(tEnums)
                .AddItem
                .List(i, 0) = tEnums(i).EnumName
                .List(i, 1) = tEnums(i).EnumValue
Print #hndOut, "Private Const " & tEnums(i).EnumName & " As Long = " & tEnums(i).EnumValue & vbTab & "' " & tEnums(i).EnumName
            Next i
        End With
       
        UserForm1.Show
Close #hndOut
    End If
End Sub

Sub Test_Lib_By_GUID()
    Dim tEnums() As Enums, i As Long
    Dim GUID As String, MinorVersion As Long, MajorVersion As Long
    Dim hndOut As Integer
   
    GUID = "{00020813-0000-0000-C000-000000000046}"
    MinorVersion = 1
    MajorVersion = 9
   
    ' GUID may vary according to the typelib version.
    tEnums() = GetTypeLibEnumsByGUID(GUID, 1, 9)
   
    If Not (Not tEnums) Then
        With UserForm1
            .Caption = "LIB GUID : " & GUID
            .Label3 = .Label3 & UBound(tEnums) + 1
        End With
hndOut = VBA.FreeFile()
Open VBA.Environ$("UserProfile") & "\Documents\Enums_" & VBA.Replace(VBA.Replace(GUID, "{", ""), "}", "") & ".bas" For Output Shared As #hndOut
        With UserForm1.ListBox1
            .ColumnWidths = "150;2"
            For i = LBound(tEnums) To UBound(tEnums)
                .AddItem
                .List(i, 0) = tEnums(i).EnumName
                .List(i, 1) = tEnums(i).EnumValue
Print #hndOut, "Private Const " & tEnums(i).EnumName & " As Long = " & tEnums(i).EnumValue & vbTab & "' " & tEnums(i).EnumName
            Next i
        End With
       
        UserForm1.Show
Close #hndOut
    End If
End Sub

Public Sub sVBE_IDE_Display_GUID_Info() 'Optional ByVal oVBProj As VBIDE.vbProject = Nothing)
' PURPOSE: Displays GUID information for each active Object Library reference in the VBA project
    Dim oVBProj As Object 'As VBIDE.vbProject   ' early biding
    Dim oVBRef As Object  'As VBIDE.Reference   ' early biding
 
'if VBproject hostApp is Excel
     Set oVBProj = Excel.ThisWorkbook.VBProject
'    Set oVBProj = Excel.Application.Workbooks("FileName.xlam/xlsm/xls").vbProject   ' if target is in another LOADED file
 
    'Loop Through Each Active Reference (Displays in Immediate Window [ctrl + g])
    For Each oVBRef In oVBProj.References
        With oVBRef
            Debug.Print "LibName: " & .Name & vbTab & "GUID: " & .GUID & ", " & .Minor & ", " & .Major
            Debug.Print "Path: ", .FullPath
            Debug.Print "-------"
        End With
    Next oVBRef
End Sub

 

[audeser]

Final, final version... at last. No more changes by my side
I have collapsed 3 procedures to just one, that outputs to Userform or to file if given a path.
Button callers remains but kept to minimum code
I have encountered problems with the GUID procedure, but could not tell what it's happening (in GetTypeLibEnumsByGUID lRet variable usually gets = 0 and then can't load Object, even if it's loaded in the project and referred GUID software installed in the machine), the other two procedures (path/object) works, so my needings are fullfilled. To bypass this problem I load the reference from it's GUID and then proceed with the Test_Lib__By_Path option from there, but I recognize it's very ugly way of solving this problem.

Option Explicit

Private tEnums() As Enums, i As Long
Private FileName As String

Public Sub Test_Lib__By_Object()
    Dim ObjectLib As Object
   
    Set ObjectLib = Excel.Application
    tEnums() = GetTypeLibEnumsByObject(ObjectLib)
    FileName = VBA.Environ$("UserProfile") & "\Documents\Enums_" & ObjectLib.Name & ".bas"
    Call fLibEnums(tEnums(), FileName)
End Sub

Public Sub Test_Lib__By_Path()
    Dim Path As String

' Excel:
    Path = Application.Path & "\Excel.exe"
   
'Other Lib paths examples for testing - Paths will need to be adjusted according to user settings.
'=================================================================================================
'    Path = "C:\Program Files\Microsoft Office\Office16\excel.exe"
'    Path = "C:\Program Files\Common Files\Microsoft Shared\OFFICE16\MSO.DLL"
'    Path = "C:\Program Files\Microsoft Office\Office16\MSWORD.OLB"
'    Path = "C:\Windows\system32\stdole32.tlb"
'    Path = "C:\Program Files\Common Files\Microsoft Shared\VBA\VBA7.1\vbe7.dll"
'    Path = "C:\Windows\system32\oleacc.dll"
'    Path = "C:\Windows\system32\ieframe.dll"
'    Path = "C:\Windows\system32\taskschd.dll"
'    Path = "C:\Windows\system32\uiautomationcore.dll"
'    Path = "C:\Windows\system32\wshom.ocx"
'    Path = "c:\windows\system32\FM20.dll"

    tEnums() = GetTypeLibEnumsByFilePath(Path)
    FileName = VBA.Environ$("UserProfile") & "\Documents\Enums_" & VBA.Replace(Path, "\", "•") & ".bas"
    Call fLibEnums(tEnums(), FileName)
End Sub

Public Sub Test_Lib__By_GUID()
    Dim GUID As String, MinorVersion As Long, MajorVersion As Long
   
    GUID = "{00020813-0000-0000-C000-000000000046}"
    MinorVersion = 1
    MajorVersion = 9

    ' GUID may vary according to the typelib version.
    tEnums() = GetTypeLibEnumsByGUID(GUID, MinorVersion, MajorVersion)
    If Not (Not tEnums) Then ' if any problem arises while getting Enums from it's GUID, try to bypass GUID via loading it (properly, it should try to find in reference list which one matches the GUID, instead of loading it...)
        ' loads a reference from it's GUID:
        Dim oVBProj As Object 'As VBIDE.vbProject   'if early biding, with Reference properly set to Microsoft VBA for Extensibility 5.3
        Dim oVBRef As Object  'As VBIDE.Reference   'if early biding
        With oVBProject.References
            Set oVBRef = .AddFromGuid(GUID:=GUID, Major:=MajorVersion, Minor:=MinorVersion)
            tEnums() = GetTypeLibEnumsByFilePath(oVBRef.FullPath)
        End With
    End If
    FileName = VBA.Environ$("UserProfile") & "\Documents\Enums" & VBA.Replace(VBA.Replace(GUID, "{", ""), "}", "") & ".bas"
    Call fLibEnums(tEnums(), FileName)
End Sub

Private Function fLibEnums(ByRef tEnums() As Enums, _
                           Optional FileName As String = vbNullString)
    Dim i As Long
    Dim hndOut As Integer
    Dim Caption As String

    If Not (Not tEnums) Then
        With UserForm1
            Caption = FileName
            Caption = VBA.Mid(Caption, VBA.InStrRev(Caption, "\") + 1)
            Caption = VBA.Mid(Caption, 1, VBA.Len(Caption) - 4)
            Select Case True
                Case FileName Like "????????-????-????-????-????????????"
                    .Caption = "LIB GUID : " & VBA.Mid(Caption, VBA.Len("Enums_") + 1)
                Case FileName Like "*•*"
                    .Caption = "LIB PATH : " & VBA.Replace(Caption, VBA.Mid(Caption, VBA.Len("Enums_") + 1), "\")
                Case Else
                    .Caption = "Test_Lib_By_Object: " & VBA.Mid(Caption, VBA.Len("Enums_") + 1)
            End Select
   
            .Label3 = .Label3 & UBound(tEnums) + 1
        End With
       
        hndOut = VBA.FreeFile()
        If Not FileName = vbNullString Then Open FileName For Output Shared As #hndOut
        With UserForm1.ListBox1
            .ColumnWidths = "150;2"
            For i = LBound(tEnums) To UBound(tEnums)
                .AddItem
                .List(i, 0) = tEnums(i).EnumName
                .List(i, 1) = tEnums(i).EnumValue
            If Not FileName = vbNullString Then Print #hndOut, "Private Const " & tEnums(i).EnumName & " As Long = " & tEnums(i).EnumValue  '& vbTab & "' " & tEnums(i).EnumName
            Next i
        End With
       
        If FileName = vbNullString Then UserForm1.Show
        Close #hndOut
    End If
End Function

' Helper function
Public Sub sVBE_IDE_Display_GUID_Info() 'Optional ByVal oVBProj As VBIDE.vbProject = Nothing)
' Displays GUID information for each active Object Library reference in the VBA project
   
    Dim oVBProj As Object 'As VBIDE.vbProject   ' early biding
    Dim oVBRef As Object  'As VBIDE.Reference   ' early biding
 
'if VBproject hostApp is Excel
     Set oVBProj = Excel.ThisWorkbook.VBProject
'    Set oVBProj = Excel.Application.Workbooks("FileName.xlam/xlsm/xls").vbProject   ' if target is in another LOADED file

    On Error Resume Next
    'Loop Through Each Active Reference (Displays in Immediate Window [ctrl + g])
    For Each oVBRef In oVBProj.References
        With oVBRef
            Debug.Print "LibName: " & .Name & vbTab & "GUID: " & .GUID & ", " & .Minor & ", " & .Major
            Debug.Print "Path: ", .FullPath
            Debug.Print "-------"
        End With
    Next oVBRef
    On Error GoTo 0
End Sub

 

[audeser]

correction (a nightmare that never ends) on Test_Lib_by_GUID in order not to crash when object was already loaded on project:

Public Sub Test_Lib_by_GUID()
    Dim GUID As String, MinorVersion As Long, MajorVersion As Long
 
    GUID = "{00020813-0000-0000-C000-000000000046}"
    MinorVersion = 1
    MajorVersion = 9

    ' GUID may vary according to the typelib version.
    tEnums() = GetTypeLibEnumsByGUID(GUID, MinorVersion, MajorVersion)
    If Not (Not tEnums) Then
    Else
        ' if any problem arises while getting Enums from it's GUID, try to bypass GUID path
        ' load a reference from it's GUID:
        Dim oVBProject As Object    'As VBIDE.vbProject   ' early biding
        Dim oVBReference As Object  'As VBIDE.Reference   ' early biding
        Set oVBProject = Excel.ThisWorkbook.VBProject
        With oVBProject.References
            For Each oVBReference In oVBProject.References
                With oVBReference
                    If .GUID = GUID Then Exit For
                End With
            Next oVBReference
            If oVBReference Is Nothing Then ' was not found
                On Error Resume Next
                Set oVBReference = .AddFromGuid(GUID:=GUID, Major:=MajorVersion, Minor:=MinorVersion)
                On Error GoTo 0
            End If
            If Not Err.Number = 32813 And Not oVBReference Is Nothing Then
                tEnums() = GetTypeLibEnumsByFilePath(oVBReference.FullPath)
            End If
        End With
    End If
    FileName = VBA.Environ$("UserProfile") & "\Documents\Enums" & VBA.Replace(VBA.Replace(GUID, "{", ""), "}", "") & ".bas"
    Call fLibEnums(tEnums(), FileName)
End Sub

 

[Jaafar Tribak]

Thanks for sharing and happy to see that the code was of help