All sorts of wonderful things are accessible via GetObject and then using a custom object activation schema, one day I will itemise all those that I have seen. In the meantime here is an example of querying the Registry using WMI to illustrate its usage.
The code loop through the typelib key in that part of the registry that handles COM. What we can output is something very similar to the Tools->References dialog box in VBA; and if we dump to sheet then we can easily search.
Option Explicit
Option Private Module
'https://msdn.microsoft.com/en-us/library/aa390387(v=vs.85).aspx
Private Const HKCR = &H80000000
'*********************************************************************************
'* Late binding but one could use a Type library reference
'* Microsoft WMI Scripting V1.2 Library
'*********************************************************************************
Private oWMIReg As Object '* Late bound
'Private oWMIReg As WbemScripting.SWbemObjectEx '* Early bound
Private lPass As Long
Private lRows As Long
Private vOutput
Private Enum coColumnOrdinals
coGuid = 1
coVersion
coDescription
coPIAName
coPIACodeBase
coWin32Binary
coWin64Binary
coFlags
coHelpdir
coMax = coHelpdir
End Enum
'**********************************************************************************
'* Entry Point
'**********************************************************************************
Sub Main()
Dim sComputer As String
sComputer = "."
Set oWMIReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
sComputer & "\root\default:StdRegProv")
Debug.Assert TypeName(oWMIReg) = "SWbemObjectEx"
Dim sKeyPath As String
sKeyPath = "TypeLib"
Dim vTypeLibraryGuids As Variant
Call oWMIReg.EnumKey(HKCR, sKeyPath, vTypeLibraryGuids)
For lPass = 0 To 1
lRows = 0
Dim vTypeLibraryGuidsLoop As Variant
For Each vTypeLibraryGuidsLoop In vTypeLibraryGuids
ReadTypeLibGuid sKeyPath, vTypeLibraryGuidsLoop
Next vTypeLibraryGuidsLoop
If lPass = 0 Then ReDim vOutput(1 To lRows, 1 To coMax)
Next lPass
Dim vColHeaders As Variant
vColHeaders = Array("Guid", "Version", "Description", "PIAName", _
"PIACodeBase", "Win32", "Win64", "Flags", "HelpDir")
Sheet1.Cells.Clear
Sheet1.Cells(1, 1).Resize(1, coMax).Value = _
Application.Transpose(Application.Transpose(vColHeaders)) '* 1d to 2d
Sheet1.Cells(1, 1).Offset(1).Resize(lRows, coMax).Value = vOutput
End Sub
'**********************************************************************************
'* Handles reading the type library details given a HKCR\typelib\{guid}
'**********************************************************************************
Sub ReadTypeLibGuid(ByVal sKeyPath As String, ByVal sTypeLibraryGuid As String)
Dim sPath As String
sPath = sKeyPath & "\" & sTypeLibraryGuid
Dim vVersions As Variant
Call oWMIReg.EnumKey(HKCR, sPath, vVersions)
If Not IsNull(vVersions) Then
Dim vVersionLoop As Variant
For Each vVersionLoop In vVersions
ReadTypeLibVersion sPath & "\" & vVersionLoop, sTypeLibraryGuid, _
vVersionLoop
Next vVersionLoop
End If
End Sub
'**********************************************************************************
'* Handles reading the type library version details
'* given a HKCR\typelib\{guid}\{version}
'**********************************************************************************
Function ReadTypeLibVersion(ByVal sPath2 As String, _
ByVal vTypeLibraryGuidsLoop2 As String, ByVal vVersionLoop2 As String)
lRows = lRows + 1
If lPass = 1 Then
vOutput(lRows, coGuid) = vTypeLibraryGuidsLoop2
vOutput(lRows, coVersion) = vVersionLoop2
End If
ReadTypeLibVersionValues sPath2
ReadTypeLibVersionKeys sPath2
End Function
'**********************************************************************************
'* Handles reading the type library version keys
'* given a HKCR\typelib\{guid}\{version}
'**********************************************************************************
Function ReadTypeLibVersionKeys(ByVal sPath2 As String)
Dim vVersionDetailKeys As Variant
Call oWMIReg.EnumKey(HKCR, sPath2, vVersionDetailKeys)
If Not IsNull(vVersionDetailKeys) Then
Dim vVersionDetailKeysLoop As Variant
For Each vVersionDetailKeysLoop In vVersionDetailKeys
Dim bIsWellKnownKey As Boolean
bIsWellKnownKey = FoundInPipes("Flags|Helpdir", vVersionDetailKeysLoop)
If lPass = 1 Then
If bIsWellKnownKey Then
Select Case LCase(vVersionDetailKeysLoop)
Case "flags"
Dim sFlags As String
sFlags = GetRegString(sPath2 & "\Flags", "")
vOutput(lRows, coFlags) = sFlags
Case "helpdir"
Dim sHelpdir As String
sHelpdir = GetRegString(sPath2 & "\Helpdir", "")
vOutput(lRows, coHelpdir) = sHelpdir
Case Else
Stop
End Select
End If
End If
If Not bIsWellKnownKey And IsNumeric(vVersionDetailKeysLoop) Then
If lPass = 1 Then
If Len(vOutput(lRows, coDescription)) > 0 Then
FindWin3264 sPath2 & "\" & vVersionDetailKeysLoop
End If
End If
End If
Next vVersionDetailKeysLoop
End If
End Function
'**********************************************************************************
'* Handles reading the type library version values
'* given a HKCR\typelib\{guid}\{version}
'**********************************************************************************
Function ReadTypeLibVersionValues(ByVal sPath2 As String)
Dim vVersionDetailValues As Variant
Call oWMIReg.EnumValues(HKCR, sPath2, vVersionDetailValues)
Dim sDesc As String
If IsNull(vVersionDetailValues) Then
If lPass = 1 Then
sDesc = GetRegString(sPath2, "")
vOutput(lRows, coDescription) = sDesc
End If
Else
Dim vVersionDetailValueLoop As Variant
For Each vVersionDetailValueLoop In vVersionDetailValues
If lPass = 1 Then
Select Case True
Case Len(vVersionDetailValueLoop) = 0
sDesc = GetRegString(sPath2, "")
vOutput(lRows, coDescription) = sDesc
Case vVersionDetailValueLoop = "PrimaryInteropAssemblyName"
Dim sPIA As String
sPIA = GetRegString(sPath2, "PrimaryInteropAssemblyName")
vOutput(lRows, coPIAName) = sPIA
Case vVersionDetailValueLoop = "PrimaryInteropAssemblyCodeBase"
Dim sPIACodeBase As String
sPIACodeBase = GetRegString(sPath2, _
"PrimaryInteropAssemblyCodeBase")
vOutput(lRows, coPIACodeBase) = sPIACodeBase
Case Else
Stop
End Select
End If
Next vVersionDetailValueLoop
End If
End Function
'**********************************************************************************
'* Syntactic sugar to compact code
'**********************************************************************************
Function GetRegString(ByVal sPath As String, sValue As String) As String
Dim sRet As String
oWMIReg.GetStringValue HKCR, sPath, sValue, sRet
GetRegString = sRet
End Function
'**********************************************************************************
'* Handles reading the win32 and win64 keys under the version key
'**********************************************************************************
Function FindWin3264(ByVal sPath As String)
Dim vPlatforms As Variant: vPlatforms = Empty
Call oWMIReg.EnumKey(HKCR, sPath, vPlatforms)
If IsNull(vPlatforms) Then
Dim sPlatform As String: sPlatform = ""
sPlatform = GetRegString(sPath & "\" & "win32", "")
vOutput(lRows, coWin32Binary) = sPlatform
sPlatform = GetRegString(sPath & "\" & "win64", "")
vOutput(lRows, coWin64Binary) = sPlatform
Debug.Assert Len(vOutput(lRows, coWin32Binary)) + _
Len(vOutput(lRows, coWin64Binary)) > 0
Else
Dim vPlatformLoop As Variant
For Each vPlatformLoop In vPlatforms
If Not FoundInPipes("Flags", vPlatformLoop) Then
Dim sPlatformLoop As String: sPlatformLoop = ""
sPlatformLoop = GetRegString(sPath & "\" & vPlatformLoop, "")
If LCase(vPlatformLoop) = "win32" Then
vOutput(lRows, coWin32Binary) = sPlatformLoop
ElseIf LCase(vPlatformLoop) = "win64" Then
vOutput(lRows, coWin64Binary) = sPlatformLoop
Else
Stop
End If
End If
Next
End If
End Function
'**********************************************************************************
'* Syntactic sugar to wrap Instr
'**********************************************************************************
Function Found(ByVal String1 As String, ByVal String2 As String, _
Optional Compare As VbCompareMethod = vbTextCompare) As Boolean
Found = (InStr(1, String1, String2, Compare) > 0)
End Function
'**********************************************************************************
'* Syntactic sugar to wrap Instr
'**********************************************************************************
Function FoundInPipes(ByVal String1 As String, ByVal String2 As String, _
Optional Compare As VbCompareMethod = vbTextCompare) As Boolean
FoundInPipes = _
(InStr(1, "|" & String1 & "|", "|" & String2 & "|", Compare) > 0)
End Function
No comments:
Post a Comment