List All Tool Reference: Used and Unused

[jstevens]

I'm having a challenge generating a list of all Tool References using this bit of code. I'm encountering an error: ActiveX component can't create object.

Code: Select all

Sub ListAllReferenceLocations()
    Dim ref As Object
    Dim references As Object
    
    Set references = CreateObject("Scripting.Dictionary")
    For Each ref In CreateObject("VBIDE.VBE").VBProjects(1).references  'This is where I'm encountering an ActiveX error.
        If Not references.Exists(ref.Name) Then
            references(ref.Name) = ref.FullPath
        End If
    Next ref
    
    Dim key As Variant
    For Each key In references
        Debug.Print references(key)
    Next key
End Sub

Your thoughts are appreciated.

[HansV]

Try this instead:

Code: Select all

Sub ListAllReferenceLocations()
    Dim ref As Object
    Dim references As Object
    
    Set references = CreateObject("Scripting.Dictionary")
    For Each ref In ActiveWorkbook.VBProject.references  'This is where I'm encountering an ActiveX error.
        If Not references.Exists(ref.Name) Then
            references(ref.Name) = ref.FullPath
        End If
    Next ref
    
    Dim key As Variant
    For Each key In references
        Debug.Print references(key)
    Next key
End Sub

[jstevens]

Hans,

Using the ActiveWorkbook.VBProject only returns those references being used. I'm after a complete list: used and not used.

[HansV]

To get all available references, you need to trawl through the HKEY_CLASSES_ROOT\TypeLib branch of the registry. The following code has been adapted from How to get programmatically a list of all available references of a VBA project. I made it a lot faster.

This is the entire code module. RefList is the macro to run; it will overwrite the contents of the active worksheet.

Code: Select all

Option Explicit

Declare PtrSafe Function RegOpenKeyEx _
    Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _
       ByVal hKey As LongPtr, _
       ByVal lpSubKey As String, _
       ByVal ulOptions As Long, _
       ByVal samDesired As Long, _
       phkResult As LongPtr) As Long
Declare PtrSafe Function RegEnumKey _
    Lib "advapi32.dll" Alias "RegEnumKeyA" ( _
        ByVal hKey As LongPtr, _
        ByVal dwIndex As Long, _
        ByVal lpName As String, _
        ByVal cbName As Long) As Long
Declare PtrSafe Function RegQueryValue _
    Lib "advapi32.dll" Alias "RegQueryValueA" ( _
        ByVal hKey As LongPtr, _
        ByVal lpSubKey As String, _
        ByVal lpValue As String, _
        lpcbValue As Long) As Long
Declare PtrSafe Function RegCloseKey _
    Lib "advapi32.dll" ( _
        ByVal hKey As LongPtr) As Long

Private Const HKEY_CLASSES_ROOT As Long = &H80000000
Private Const READ_CONTROL As Long = &H20000
Private Const STANDARD_RIGHTS_READ As Long = (READ_CONTROL)
Private Const KEY_QUERY_VALUE As Long = &H1
Private Const KEY_ENUMERATE_SUB_KEYS As Long = &H8
Private Const KEY_NOTIFY As Long = &H10
Private Const SYNCHRONIZE As Long = &H100000
Private Const KEY_READ As Long = (( _
                  STANDARD_RIGHTS_READ _
               Or KEY_QUERY_VALUE _
               Or KEY_ENUMERATE_SUB_KEYS _
               Or KEY_NOTIFY) _
               And (Not SYNCHRONIZE))
Private Const ERROR_SUCCESS As Long = 0&
Private Const ERROR_NO_MORE_ITEMS As Long = 259&

Private Sub RefList()
    Dim R1 As Long
    Dim R2 As Long
    Dim hHK1 As Long
    Dim hHK2 As Long
    Dim hHK3 As Long
    Dim hHK4 As Long
    Dim i As Long
    Dim i2 As Long
    Dim lpPath As String
    Dim lpGUID As String
    Dim lpName As String
    Dim lpValue As String
    Dim Output(1 To 10000, 1 To 3) As String
    lpPath = String$(128, vbNullChar)
    lpValue = String$(128, vbNullChar)
    lpName = String$(128, vbNullChar)
    lpGUID = String$(128, vbNullChar)
    R1 = RegOpenKeyEx(HKEY_CLASSES_ROOT, "TypeLib", ByVal 0&, KEY_READ, hHK1)
    If R1 = ERROR_SUCCESS Then
        i = 0
        Do While Not R1 = ERROR_NO_MORE_ITEMS
            R1 = RegEnumKey(hHK1, i, lpGUID, Len(lpGUID))
            If R1 = ERROR_SUCCESS Then
                R2 = RegOpenKeyEx(hHK1, lpGUID, ByVal 0&, KEY_READ, hHK2)
                If R2 = ERROR_SUCCESS Then
                    i2 = 0
                    Do While Not R2 = ERROR_NO_MORE_ITEMS
                        R2 = RegEnumKey(hHK2, i2, lpName, Len(lpName)) '1.0
                        If R2 = ERROR_SUCCESS Then
                            RegQueryValue hHK2, lpName, lpValue, Len(lpValue)
                            RegOpenKeyEx hHK2, lpName, ByVal 0&, KEY_READ, hHK3
                            RegOpenKeyEx hHK3, "0", ByVal 0&, KEY_READ, hHK4
                            RegQueryValue hHK4, "win32", lpPath, Len(lpPath)
                            i2 = i2 + 1
                            Output(i + 1, 1) = lpGUID
                            Output(i + 1, 2) = lpValue
                            Output(i + 1, 3) = lpPath
                        End If
                    Loop
                End If
            End If
            i = i + 1
        Loop
        RegCloseKey hHK1
        RegCloseKey hHK2
        RegCloseKey hHK3
        RegCloseKey hHK4
    End If
    Range("A1:C10000").Value = Output
    Columns("A:A").EntireColumn.AutoFit
    Columns("B:C").ColumnWidth = 70
    Range("A1").CurrentRegion.Sort Key1:=Range("B1")
End Sub

[jstevens]

Hans,

I encountered an error at: R1 = RegOpenKeyEx(HKEY_CLASSES_ROOT, "TypeLib", ByVal 0&, KEY_READ, hHK1)

Specifically on hHK1

Error reads: ByRef argument type mismatch

[jstevens]

Hans,

I was able to get the code to work with a minor tweak.

Code: Select all

[code][code]
Private Sub RefList()
    Dim R1 As Long
    Dim R2 As Long
    Dim hHK1 As LongPtr   'Changed from Long to LongPtr 
    Dim hHK2 As LongPtr   'Changed from Long to LongPtr 
    Dim hHK3 As LongPtr   'Changed from Long to LongPtr
    Dim hHK4 As LongPtr   'Changed from Long to LongPtr

[/code][/code]

Thank you.