Embedded Files
This function returns a data object which we can search through to find an OLEDB provider we can use.
Example:
I often pass OLEDBs to Exists() to determine if a required database provider is installed on a PC before accessing records.
If Exists(OLEDBs, "Microsoft.Jet.OLEDB.4.0") Then...
Requisites: DspErrMsg()
Public Function OLEDBs(Optional bList As Boolean = False) As Object
' Description:Creates a dictionary of OLE DBs
' Inputs: bList If TRUE lists OLEDBs
' Outputs me Success: OLE DB Providers Collection
' Failure: Nothing
' Notes: Based on Patrick R. O'Beirn's post
‘ https://sysmod.wordpress.com/2014/07/11/vbscript-to-list-installed-oledb-providers/
' Examples: OLEDBs bList:=TRUE
' Date Ini Modification
' 10/28/16 CWH Initial Development
' Declarations
Const cRoutine As String = "OLEDBs"
Const HKEY_CLASSES_ROOT As Long = &H80000000 'Registry Root
Const sComputer As String = "." 'This Computer
Static oDic As Object 'OLEDB Dictionary
Dim oReg As Object 'Registry
Dim vKeys As Variant 'Keys array
Dim vKey As Variant 'Single Key
Dim sPath As String 'Key's Registry Path
Dim sName As String 'Key's Value Name
Dim sValue As String 'String Value
Dim dwValue As Long 'dWord Value
' Error Handling Initialization
On Error GoTo ErrHandler
Set OLEDBs = Nothing 'Assume not found
' Procedure
' Create dictionary if needed
If oDic Is Nothing Then
Set oDic = CreateObject("Scripting.Dictionary")
' Connect to Registry
Set oReg = GetObject( _
"winmgmts:{impersonationLevel=impersonate}!\\" & _
sComputer & "\root\default:StdRegProv")
' Get all CLSID keys
oReg.enumKey HKEY_CLASSES_ROOT, "CLSID", vKeys
' Search CLSID Keys for OLEDB providers
For Each vKey In vKeys
sPath = "CLSID\" & vKey
sName = "OLEDB_SERVICES"
If oReg.GetDWordValue(HKEY_CLASSES_ROOT, sPath, sName, dwValue) = 0 Then
oReg.GetStringValue HKEY_CLASSES_ROOT, sPath, "", sValue
oDic(sValue) = "HKEY_CLASSES_ROOT\" & sPath
End If
Next
End If
' List Providers if requested
If bList Then
For Each vKey In oDic.Keys()
Debug.Print oDic(vKey), vKey
Next
End If
Set OLEDBs = oDic
ErrHandler:
Select Case Err.Number
Case Is = NoError: 'Do nothing
Case Else:
Select Case DspErrMsg(cModule & "." & cRoutine)
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Select
End Function
Page updated
Google Sites
Report abuse