VBA - OLEDB Connections
Hi gurus, I have a VBA code here that reads all excel files in a folder and its subdirectories and lists the workbooks' connection strings and sql commands. Right now it's only reading and writing ODBC connections. How can I make the code read not just ODBC connections but also OLEDB? Thanks. (Might wanna check Private Sub CheckFileConnections).
Private Const FILE_FILTER = "*.xl*"
    Private Const sRootFDR = "N:\" ' Root Folder
    
    Private oFSO As Object ' For FileSystemObject
    Private oRng As Range, N As Long ' Range object and Counter
    
    Sub Main()
        Application.ScreenUpdating = False
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        N = 0
        With ThisWorkbook.Worksheets("Sheet1")
            .UsedRange.ClearContents ' Remove previous contents
            .Range("A1:E1").Value = Array("Filename", "Connections", "Connection String", "Command Text", "Date Scanned")
            Set oRng = .Range("A2") ' Initial Cell to start storing results
        End With
        Columns("A:E").Select
        With Selection
            .WrapText = True
            .ColumnWidth = 45
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlCenter
        End With
        ListFolder sRootFDR
        Application.ScreenUpdating = True
        Set oRng = Nothing
        Set oFSO = Nothing
        Columns.AutoFit
        MsgBox N & " Excel files has been checked for connections."
    End Sub
    
    Private Sub ListFolder(ByVal sFDR As String)
        Dim oFDR As Object, lFDR As Object
        ' List the files of this Directory
        ListFiles sFDR, FILE_FILTER
        ' Recurse into each Sub Folder
        On Error GoTo Handler
        For Each oFDR In oFSO.GetFolder(sFDR).SubFolders
        ListFolder oFDR.Path & "\" ' Need '\' to ensure the file filter works
        Next
        Exit Sub
    Handler:
        If Err.Number = 70 Then
            oRng.Value = sFDR
            oRng.Offset(0, 1).Value = "Inaccessible file - access denied"
        End If
        Resume Next
    End Sub
    
    Private Sub ListFiles(ByVal sFDR As String, ByVal sFilter As String)
        Dim sItem As String
        On Error Resume Next
        sItem = Dir(sFDR & sFilter)
        Do Until sItem = ""
            N = N + 1 ' Increment Counter
            oRng.Value = sFDR & sItem
            CheckFileConnections oRng.Value ' Call Sub to Check the Connection settings
            oRng.Offset(0, 4) = Now
            Set oRng = oRng.Offset(1) ' Move Range object to next cell below
            sItem = Dir
        Loop
    End Sub
    
    Private Sub CheckFileConnections(ByVal sFile As String)
        Dim oWB As Workbook, oConn As WorkbookConnection
        Dim sConn As String, sCMD As String
        Dim ConnectionNumber As Integer
        ConnectionNumber = 1
        If Left(sFile, 24) = "L:\Cherwell\Attachments\" Then
            Exit Sub
        End If
        If Left(sFile, 10) = "L:\BruceG\" Then
            Exit Sub
        End If
        Application.StatusBar = "Opening workbook: " & sFile
        On Error Resume Next
        Set oWB = Workbooks.Open(Filename:=sFile, ReadOnly:=True, UpdateLinks:=False, Password:=userpass)
        If Err.Number > 0 Then
            oRng.Offset(0, 1).Value = "Password protected file"
        Else
        With oWB
            For Each oConn In .Connections
                If Len(sConn) > 0 Then sConn = sConn & vbLf
                If Len(sCMD) > 0 Then sCMD = sCMD & vbLf
                sConn = sConn & oConn.ODBCConnection.Connection
                sCMD = sCMD & oConn.ODBCConnection.CommandText
                
                oRng.Offset(0, 1).Value = ConnectionNumber ' 1 column to right (B)
                oRng.Offset(0, 2).Value = oConn.ODBCConnection.Connection ' 2 columns to right (C)
                oRng.Offset(0, 3).Value = oConn.ODBCConnection.CommandText ' 3 columns to right (D)
                ConnectionNumber = ConnectionNumber + 1
                Set oRng = oRng.Offset(1) ' Move Range object to next cell below
            Next
        End With
        End If
        oWB.Close False ' Close without saving
        Set oWB = Nothing
        Application.StatusBar = False
    End Sub

April 3rd, 2015 2:58pm

This topic is archived. No further replies will be accepted.

Other recent topics Other recent topics