Code:
Option Explicit
Private Const HKEY_CLASSES_ROOT As Long = &H80000000
Private Const KEY_READ As Long = &H20019
Private Const ERROR_NO_MORE_ITEMS As Long = 259
#If VBA7 Then ' The next line turns red for Excel versions under 2010, - nothing to worry about
Private Declare PtrSafe Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare PtrSafe Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcName As Long, ByVal reserved As Long, ByVal lpClass As String, lpcClass As Long, lpftLastWriteTime As Any) As Long
Private Declare PtrSafe Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
#Else
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcName As Long, ByVal reserved As Long, ByVal lpClass As String, lpcClass As Long, lpftLastWriteTime As Any) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
#End If
' Mike https://eileenslounge.com/viewtopic.php?p=326278#p326278
Private Sub EnumerateTypeLibsWithDetails()
Dim hKey As Long
Dim result As Long
Dim index As Long
Dim keyName As String
Dim keyNameLen As Long
Dim version As String
Dim LibName As String
' Open HKEY_CLASSES_ROOT\TypeLib
result = RegOpenKeyEx(HKEY_CLASSES_ROOT, "TypeLib", 0, KEY_READ, hKey)
If result <> 0 Then
MsgBox "Failed to open registry key!", vbCritical
Exit Sub
End If
' Enumerate all subkeys
index = 0
Do
keyName = String(255, 0)
keyNameLen = 255
result = RegEnumKeyEx(hKey, index, keyName, keyNameLen, 0, vbNullString, 0, ByVal 0)
If result = ERROR_NO_MORE_ITEMS Then Exit Do
If result = 0 Then
keyName = Trim(Left$(keyName, keyNameLen)) ' TypeLib GUID
' Get the latest version
version = GetLatestVersion("TypeLib\" & keyName)
If version <> "" Then
' Get the TypeLib name
LibName = GetRegistryString(HKEY_CLASSES_ROOT, "TypeLib\" & keyName & "\" & version, "")
ActiveSheet.Range("A" & index + 1 + 2).Value = keyName
ActiveSheet.Range("B" & index + 1 + 2).Value = version
ActiveSheet.Range("C" & index + 1 + 2).Value = LibName
End If
End If
index = index + 1
Loop
' Close registry key
RegCloseKey hKey
End Sub
Private Function GetRegistryString(hKey As Long, subKey As String, valueName As String) As String
Dim hSubKey As Long
Dim result As Long
Dim valueType As Long
Dim valueData As String
Dim valueSize As Long
' Open the registry key
result = RegOpenKeyEx(hKey, subKey, 0, KEY_READ, hSubKey)
If result <> 0 Then Exit Function
' Determine the size of the data
valueSize = 255
valueData = String(valueSize, 0)
result = RegQueryValueEx(hSubKey, valueName, 0, valueType, ByVal valueData, valueSize)
If result = 0 Then
GetRegistryString = Left$(valueData, InStr(valueData, Chr$(0)) - 1)
End If
' Close the key
RegCloseKey hSubKey
End Function
Private Function GetLatestVersion(ByVal baseKey As String) As String
Dim hKey As Long
Dim result As Long
Dim index As Long
Dim version As String
Dim versionLen As Long
Dim latestVersion As String
' Open the base key
result = RegOpenKeyEx(HKEY_CLASSES_ROOT, baseKey, 0, KEY_READ, hKey)
If result <> 0 Then Exit Function
' Enumerate all subkeys (versions)
index = 0
Do
version = String(255, 0)
versionLen = 255
result = RegEnumKeyEx(hKey, index, version, versionLen, 0, vbNullString, 0, ByVal 0)
If result = ERROR_NO_MORE_ITEMS Then Exit Do
If result = 0 Then
version = Trim(Left$(version, versionLen))
' Keep track of the latest version
If version > latestVersion Then latestVersion = version
End If
index = index + 1
Loop
' Close the registry key
RegCloseKey hKey
' Return the latest version found
GetLatestVersion = latestVersion
End Function
Reply With Quote
Bookmarks