Audit DSNs from the machine registry

We want to know all the system DSNs for a machine, so we audit two areas: the DSNs for 32 and 64 bit.  They are in HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\ODBC\ODBCINST.INI and HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBCINST.INI.  We want to look into the ODBC Drivers key for the list of drivers, and then the subkeys show us the actual info for the DSNs.

It gets tricky because we want to read the 6 4 bit area of the registry, using the 32 Excel app.

Improved: now includes reading the user DSNs.

[VBA code for Excel]
Option Explicit
' Version 1.7.2.0
' Author: Roger C
; Date 16-Aug-2017

Const HKLM = &H80000002
Const HKU = &H80000003

Dim CurrentHostnamesRow
Dim CurrentODBC_DriversRow, CurrentODBCDataSourcesRow
Dim CurrentODBCINST_INIRows, CurrentDSNsRows
Dim objRegistryConnection ' stores the connection to the remote registry

Dim ObjCtx
Dim objLocator
Dim objServices
Dim objStdRegProv
Dim arrExceptionDSNs(43)


Private Sub BtnStart_Click()
Dim i, j
Sheets("Hostnames").Range("C2:D1000").Value = ""
Sheets("DSNs").Range("A2:F10000").Value = ""
Sheets("User Drivers").Range("A2:F10000").Value = ""
Sheets("System Drivers").Range("A2:F10000").Value = ""
Sheets("ODBCINST.INI").Range("A2:o10000").Value = ""

Dim HostName, PingResult
CurrentHostnamesRow = 2 '  <- start at 2 normally, or another row to skip work already performed
CurrentODBC_DriversRow = 2
CurrentODBCDataSourcesRow = 2
CurrentODBCINST_INIRows = 2
CurrentDSNsRows = 2

lblProcessed.Caption = 0
lblStatus.Caption = "Processing"
While Sheets("Hostnames").Range("A" & CurrentHostnamesRow).Value <> ""
    DoEvents
    HostName = Sheets("Hostnames").Range("A" & CurrentHostnamesRow).Value
    lblCurrentHost = HostName
    LblHostStatus.Caption = "Processing"
    Sheets("Hostnames").Range("C" & CurrentHostnamesRow).Value = "Processing"
    PingResult = GetPingResult(HostName)
    Sheets("Hostnames").Range("C" & CurrentHostnamesRow).Value = PingResult
    If PingResult <> "Connected" Then
        Sheets("Hostnames").Range("D" & CurrentHostnamesRow).Value = "N/A"
    Else
        Sheets("Hostnames").Range("D" & CurrentHostnamesRow).Value = "Processing"
        If CanConnectToRegistry(HostName) Then
            Call ReadHKeyLocalMachineHive(HostName)
            Call ReadHKeyUsersHive(HostName)
        End If
    End If
    
    CurrentHostnamesRow = CurrentHostnamesRow + 1
    lblProcessed.Caption = lblProcessed.Caption + 1
Wend

lblStatus.Caption = "Done"
lblCurrentHost = ""
LblHostStatus.Caption = ""
Set objRegistryConnection = Nothing

BtnStart.Visible = False

End Sub
Sub ReadHKeyUsersHive(ThisHost)
    ' iterate through the subkeys in the HKEY_USERS hive (just 32 bit)
    Dim i, InParams, OutParams, ThisSid
    
    Call InitStdRegProv(ThisHost, 32)
    Set InParams = objStdRegProv.Methods_("EnumKey").Inparameters
                   InParams.Hdefkey = HKU
                   InParams.sSubKeyName = "" ' Root of hive
        
    Set OutParams = objStdRegProv.ExecMethod_("EnumKey", InParams, , ObjCtx)   '< - read the DSN names
    ' returns OutParams.sNames  - array of subkeys (DSNs) in this key
    
    For i = 0 To UBound(OutParams.sNames) ' iterate through the subkeys (the user SIDs)
        ThisSid = OutParams.sNames(i)
        If ThisSid <> ".DEFAULT" _
            And Right(ThisSid, 8) <> "_Classes" Then
            Debug.Print ThisSid
            Call ReadODBC_Drivers(ThisHost, HKU, ThisSid & "\SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources", 32, "User", "User Drivers")
            Call Read_ODBCINST_INI(ThisHost, HKU, ThisSid & "\SOFTWARE\ODBC\ODBC.INI", 64, "User")
        End If
    Next
    
End Sub
Sub ReadHKeyLocalMachineHive(ThisHost)
    Call ReadODBC_Drivers(ThisHost, HKLM, "SOFTWARE\ODBC\ODBCINST.INI\ODBC Drivers", 32, "System", "System Drivers")
    Call ReadODBC_Drivers(ThisHost, HKLM, "SOFTWARE\ODBC\ODBCINST.INI\ODBC Drivers", 64, "System", "System Drivers")
    Call Read_ODBCINST_INI(ThisHost, HKLM, "SOFTWARE\ODBC\ODBCINST.INI", 32, "System")
    Call Read_ODBCINST_INI(ThisHost, HKLM, "SOFTWARE\ODBC\ODBCINST.INI", 64, "System")
    Call ReadDSNs(ThisHost, HKLM, "SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources", 32)
    Call ReadDSNs(ThisHost, HKLM, "SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources", 64)
End Sub
Sub ReadDSNs(ThisHost, ThisHive, ThisKeyPath, Bits)
' iterate through the values to find the DSN names
'
    Dim InParams, OutParams
    Dim strValueName, strValueData
    Dim i, CurrentRowThisSheet
    Dim ThisSheetName: ThisSheetName = "DSNs"

CurrentRowThisSheet = CurrentDSNsRows

    Call InitStdRegProv(ThisHost, Bits)

    Set InParams = objStdRegProv.Methods_("EnumValues").Inparameters
                    InParams.Hdefkey = ThisHive
                    InParams.sSubKeyName = ThisKeyPath
        
    Set OutParams = objStdRegProv.ExecMethod_("EnumValues", InParams, , ObjCtx) '< - execute the call to read the values in this key
        Dim arrValueNames: arrValueNames = OutParams.sNames ' array of values in this key
        Dim arrValueTypes: arrValueTypes = OutParams.Types
    
'    Dim i, strValueName, strValueData
    If Not IsNull(arrValueNames) Then
        For i = 0 To UBound(arrValueNames) ' iterate through the resulting values
            DoEvents
            Sheets(ThisSheetName).Range("A" & CurrentRowThisSheet).Value = ThisHost
'            strValueName = arrValueNames(i)

            Sheets(ThisSheetName).Range("B" & CurrentRowThisSheet).Value = arrValueNames(i)
            Set InParams = objStdRegProv.Methods_("GetStringValue").Inparameters ' <- set up to read the data of the value
                InParams.Hdefkey = ThisHive
                InParams.sSubKeyName = ThisKeyPath
                InParams.sValueName = arrValueNames(i)
                
            Set OutParams = objStdRegProv.ExecMethod_("GetStringValue", InParams, , ObjCtx) '< - execute the call to read the data
                strValueData = OutParams.sValue
                
            Sheets(ThisSheetName).Range("C" & CurrentRowThisSheet).Value = strValueData
            CurrentRowThisSheet = CurrentRowThisSheet + 1
        Next
    End If
    CurrentDSNsRows = CurrentRowThisSheet
  

End Sub
Function InitStdRegProv(ThisHost, Bits)
    ' initialize the StdRegProv provider with the correct number of bits (32/64)
    Dim IsSuccess: IsSuccess = False
    Dim MyErrSource, MyErrDesc

    Set ObjCtx = CreateObject("WbemScripting.SWbemNamedValueSet")
        ObjCtx.Add "__ProviderArchitecture", Bits
    Set objLocator = CreateObject("Wbemscripting.SWbemLocator")
    Set objServices = Nothing
    On Error Resume Next
    Set objServices = objLocator.ConnectServer(ThisHost, "root\default", "", "", , , , ObjCtx)
    MyErrSource = Err.Source
    MyErrDesc = Err.Description
    On Error GoTo 0
    
    If MyErrSource = "" Then
        On Error Resume Next
        Set objStdRegProv = objServices.Get("StdRegProv")
        MyErrSource = Err.Source
        MyErrDesc = Err.Description
        On Error GoTo 0
        
        If MyErrSource = "" Then
            IsSuccess = True
        End If
    End If
    If Not IsSuccess Then
        Sheets("Hostnames").Range("D" & CurrentHostnamesRow).Value = MyErrSource & ":" & MyErrDesc
    End If
End Function
Sub ReadODBC_Drivers(ThisHost, ThisHive, ThisKeyPath, Bits, DSN_Type, ThisSheetName)
    Dim CurrentRowThisSheet
    If Not IsObject(objStdRegProv) Then Exit Sub
    If ThisSheetName = "System Drivers" Then CurrentRowThisSheet = CurrentODBC_DriversRow
    If ThisSheetName = "User Drivers" Then CurrentRowThisSheet = CurrentODBCDataSourcesRow
    
    Call InitStdRegProv(ThisHost, Bits)
    
    Dim InParams: Set InParams = objStdRegProv.Methods_("EnumValues").Inparameters
                    InParams.Hdefkey = ThisHive
                    InParams.sSubKeyName = ThisKeyPath
        
    Dim OutParams: Set OutParams = objStdRegProv.ExecMethod_("EnumValues", InParams, , ObjCtx) '< - execute the call to read the values in this key
        Dim arrValueNames: arrValueNames = OutParams.sNames ' array of values in this key
        Dim arrValueTypes: arrValueTypes = OutParams.Types
    
    Dim i, strValueName, strValueData
    If Not IsNull(arrValueNames) Then
        For i = 0 To UBound(arrValueNames) ' iterate through the resulting values
            DoEvents
            Sheets(ThisSheetName).Range("A" & CurrentRowThisSheet).Value = ThisHost
            strValueName = arrValueNames(i)
            
            If ThisSheetName = "System Drivers" Then Sheets(ThisSheetName).Range("B" & CurrentRowThisSheet).Value = Bits & "bit"
            Sheets(ThisSheetName).Range("C" & CurrentRowThisSheet).Value = DSN_Type
            Sheets(ThisSheetName).Range("D" & CurrentRowThisSheet).Value = strValueName
            Sheets(ThisSheetName).Range("E" & CurrentRowThisSheet).Value = "REG_SZ" 'arrValueTypes(i)
            
            Set InParams = objStdRegProv.Methods_("GetStringValue").Inparameters
                InParams.Hdefkey = ThisHive
                InParams.sSubKeyName = ThisKeyPath
                InParams.sValueName = arrValueNames(i)
                
            Set OutParams = objStdRegProv.ExecMethod_("GetStringValue", InParams, , ObjCtx) '< - execute the call to read the data
                strValueData = OutParams.sValue
                
            Sheets(ThisSheetName).Range("F" & CurrentRowThisSheet).Value = strValueData
            CurrentRowThisSheet = CurrentRowThisSheet + 1
        Next
    End If
    If ThisSheetName = "System Drivers" Then CurrentODBC_DriversRow = CurrentRowThisSheet
    If ThisSheetName = "User Drivers" Then CurrentODBC_DriversRow = CurrentRowThisSheet

End Sub
Sub Read_ODBCINST_INI(ThisHost, ThisHive, ThisKeyPath, Bits, DSN_Type)
    ' iterate through the ODBCINST.INI key to find the drivers
    Dim InParams, OutParams
    Dim strValueName, strValueData
    Dim i, j
    Dim ThisSheetName: ThisSheetName = "ODBCINST.INI"
    
    Dim arrValueNames(10)
    arrValueNames(1) = "Driver"
    arrValueNames(2) = "APILevel"
    arrValueNames(3) = "ConnectFunctions"
    arrValueNames(4) = "CPTimeout"
    arrValueNames(5) = "DriverODBCVer"
    arrValueNames(6) = "FileExtns"
    arrValueNames(7) = "FileUsage"
    arrValueNames(8) = "Setup"
    arrValueNames(9) = "SQLLevel"
    arrValueNames(10) = "UsageCount"
       
    Call InitStdRegProv(ThisHost, Bits)
    
    Set InParams = objStdRegProv.Methods_("EnumKey").Inparameters
                    InParams.Hdefkey = ThisHive
                    InParams.sSubKeyName = ThisKeyPath
        
    Set OutParams = objStdRegProv.ExecMethod_("EnumKey", InParams, , ObjCtx) '< - read the driver names
    ' returns OutParams.sNames  - array of subkeys (DSNs) in this key
    
    If Not IsNull(OutParams.sNames) Then
        For i = 0 To UBound(OutParams.sNames) ' iterate through the subkeys (the DSN names)
            DoEvents
            If Not SkipThisSubKey(OutParams.sNames(i)) Then
                Sheets(ThisSheetName).Range("A" & CurrentODBCINST_INIRows).Value = ThisHost
                Sheets(ThisSheetName).Range("B" & CurrentODBCINST_INIRows).Value = Bits & "bit"
                Sheets(ThisSheetName).Range("C" & CurrentODBCINST_INIRows).Value = DSN_Type
                Sheets(ThisSheetName).Range("D" & CurrentODBCINST_INIRows).Value = OutParams.sNames(i)
                For j = 1 To UBound(arrValueNames) ' iterate through the data for this subkey (Data values for this DSN)
                    Sheets(ThisSheetName).Range(Chr(Asc("A") + j + 3) & "1").Value = arrValueNames(j) ' write the header row
                    Call WriteSubKeytoSheet(ThisHive, ThisKeyPath & "\" & OutParams.sNames(i), arrValueNames(j), j + 4)
                Next
                CurrentODBCINST_INIRows = CurrentODBCINST_INIRows + 1
            End If
        Next
    End If
End Sub
Sub WriteSubKeytoSheet(ThisHive, strKeyName, strValueName, DataColumn)
    Dim InParams, OutParams
    
    Set InParams = objStdRegProv.Methods_("GetStringValue").Inparameters ' for REG_SZ
        InParams.Hdefkey = ThisHive
        InParams.sSubKeyName = strKeyName
        InParams.sValueName = strValueName
    
    Set OutParams = objStdRegProv.ExecMethod_("GetStringValue", InParams, , ObjCtx) '< - execute the call to read the values in this key
    If OutParams.ReturnValue = 0 Then
        Sheets("ODBCINST.INI").Range(Chr(Asc("A") + DataColumn - 1) & CurrentODBCINST_INIRows).Value = OutParams.sValue
        
    Else ' failed to retrieve it as a String - try it as a DWord
        Set InParams = objStdRegProv.Methods_("getDWORDValue").Inparameters
            InParams.Hdefkey = HKLM
            InParams.sSubKeyName = strKeyName
            InParams.sValueName = strValueName
        
        Set OutParams = objStdRegProv.ExecMethod_("getDWORDValue", InParams, , ObjCtx) '< - execute the call to read the values in this key
        If OutParams.ReturnValue = 0 Then
            Sheets("ODBCINST.INI").Range(Chr(Asc("A") + DataColumn - 1) & CurrentODBCINST_INIRows).Value = OutParams.uValue
        End If
    End If
End Sub
Function CanConnectToRegistry(ThisHost)
    Dim ReturnValue, sReturnValue, ThisError
    Dim IsSuccess: IsSuccess = False
    Dim MyErrSource, MyErrDesc
    
    On Error Resume Next
    Set objRegistryConnection = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & ThisHost & "\root\default:StdRegProv")
    MyErrSource = Err.Source
    MyErrDesc = Err.Description
    On Error GoTo 0
    ThisError = Err.Number
    
    If MyErrSource = "" Then
        On Error Resume Next
        objRegistryConnection.GetStringValue HKLM, "HKEY_LOCAL_MACHINE\SOFTWARE\ODBC", "(Default)", sReturnValue
        MyErrSource = Err.Source
        MyErrDesc = Err.Description
        On Error GoTo 0
        
        If MyErrSource = "" Then
            IsSuccess = True
        End If
    End If
    If IsSuccess Then
        Sheets("Hostnames").Range("D" & CurrentHostnamesRow).Value = "Success"
    Else
        Sheets("Hostnames").Range("D" & CurrentHostnamesRow).Value = MyErrSource & ":" & MyErrDesc
    End If
    CanConnectToRegistry = IsSuccess
End Function

Function GetPingResult(ThisHost)
   Dim objPing As Object
   Dim objStatus As Object
   Dim strResult As String
   
   Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
       ExecQuery("Select * from Win32_PingStatus Where Address = '" & ThisHost & "'")

   For Each objStatus In objPing
      Select Case objStatus.StatusCode
         Case 0: strResult = "Connected"
         Case 11001: strResult = "Buffer too small"
         Case 11002: strResult = "Destination net unreachable"
         Case 11003: strResult = "Destination host unreachable"
         Case 11004: strResult = "Destination protocol unreachable"
         Case 11005: strResult = "Destination port unreachable"
         Case 11006: strResult = "No resources"
         Case 11007: strResult = "Bad option"
         Case 11008: strResult = "Hardware error"
         Case 11009: strResult = "Packet too big"
         Case 11010: strResult = "Request timed out"
         Case 11011: strResult = "Bad request"
         Case 11012: strResult = "Bad route"
         Case 11013: strResult = "Time-To-Live (TTL) expired transit"
         Case 11014: strResult = "Time-To-Live (TTL) expired reassembly"
         Case 11015: strResult = "Parameter problem"
         Case 11016: strResult = "Source quench"
         Case 11017: strResult = "Option too big"
         Case 11018: strResult = "Bad destination"
         Case 11032: strResult = "Negotiating IPSEC"
         Case 11050: strResult = "General failure"
         Case Else: strResult = "Unknown host"
      End Select
      GetPingResult = strResult
   Next
   Set objPing = Nothing
End Function

Function SkipThisSubKey(ThisDSN)
    Dim i
    If arrExceptionDSNs(1) = "" Then Call CreateDSNExceptions
    SkipThisSubKey = vbFalse
    For i = 1 To UBound(arrExceptionDSNs)
        If ThisDSN = arrExceptionDSNs(i) Then
            SkipThisSubKey = vbTrue
        End If
    Next
End Function
Sub CreateDSNExceptions()
    ' we want to see only those that are commented, or any that are not listed
    arrExceptionDSNs(1) = "Driver da Microsoft para arquivos texto (*.txt; *.csv)"
    arrExceptionDSNs(2) = "Driver do Microsoft Access (*.mdb)"
    arrExceptionDSNs(3) = "Driver do Microsoft dBase (*.dbf)"
    arrExceptionDSNs(4) = "Driver do Microsoft Excel(*.xls)"
    arrExceptionDSNs(5) = "Driver do Microsoft Paradox (*.db )"
    arrExceptionDSNs(6) = "Driver para o Microsoft Visual FoxPro"
    'arrExceptionDSNs(7) = "Microsoft Access Driver (*.mdb)"
    'arrExceptionDSNs(8) = "Microsoft Access Driver (*.mdb, *.accdb)"
    'arrExceptionDSNs(9) = "Microsoft Access Text Driver (*.txt, *.csv)"
    arrExceptionDSNs(10) = "Microsoft Access-Treiber (*.mdb)"
    arrExceptionDSNs(11) = "Microsoft dBase Driver (*.dbf)"
    arrExceptionDSNs(12) = "Microsoft dBase VFP Driver (*.dbf)"
    arrExceptionDSNs(13) = "Microsoft dBase-Treiber (*.dbf)"
    arrExceptionDSNs(14) = "Microsoft Excel Driver (*.xls)"
    arrExceptionDSNs(15) = "Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)"
    arrExceptionDSNs(16) = "Microsoft Excel-Treiber (*.xls)"
    arrExceptionDSNs(17) = "Microsoft FoxPro VFP Driver (*.dbf)"
    'arrExceptionDSNs(18) = "Microsoft ODBC for Oracle"
    arrExceptionDSNs(19) = "Microsoft Paradox Driver (*.db )"
    arrExceptionDSNs(20) = "Microsoft Paradox-Treiber (*.db )"
    arrExceptionDSNs(21) = "Microsoft Text Driver (*.txt; *.csv)"
    arrExceptionDSNs(22) = "Microsoft Text-Treiber (*.txt; *.csv)"
    arrExceptionDSNs(23) = "Microsoft Visual FoxPro Driver"
    arrExceptionDSNs(24) = "Microsoft Visual FoxPro-Treiber"
    'arrExceptionDSNs(25) = "ODBC Driver 11 for SQL Server"
    'arrExceptionDSNs(26) = "Oracle in OraClient11g_home1"
    'arrExceptionDSNs(27) = "SQL Server"
    'arrExceptionDSNs(28) = "SQL Server Native Client 11.0"
    arrExceptionDSNs(29) = "Microsoft Access dBASE Driver (*.dbf, *.ndx, *.mdx)"
    arrExceptionDSNs(20) = "Microsoft Access Driver (*.mdb, *.accdb)"
    arrExceptionDSNs(31) = "Microsoft Access Text Driver (*.txt, *.csv)"
    arrExceptionDSNs(32) = "Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)"
    'arrExceptionDSNs(33) = "ODBC Driver 11 for SQL Server"
    'arrExceptionDSNs(34) = "Oracle in OraClient11g_home1"
    arrExceptionDSNs(35) = "SQL Server"
    'arrExceptionDSNs(36) = "SQL Server Native Client 11.0"
    arrExceptionDSNs(37) = "Conversor de pagina de codigo MS"
    arrExceptionDSNs(38) = "MS Code Page Translator"
    arrExceptionDSNs(39) = "MS Code Page-Ubersetzer"
    arrExceptionDSNs(40) = "ODBC Core"
    arrExceptionDSNs(41) = "ODBC Drivers"
    arrExceptionDSNs(42) = "ODBC Translators"
    arrExceptionDSNs(43) = "ODBC Data Sources"

End Sub

Private Sub Label4_Click()

End Sub

Private Sub UserForm_Click()

End Sub

Advertisements

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s