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


