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
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).
April 3rd, 2015 2:58pm