Macros vba to list all inaccessible network folders - excel

Question

I have a vba code that scans a folder and its subdirectories for excel files and lists the connection strings and sql command. But my problem is my program doesn't list the inaccessible network folders that gives you the error "Access Denied." I wanna be able to list the path to the folder and indicate on the second column that the folder is inaccessible. How should I code it? I'm thinking
On Error GoTo Handler
Handler:
If Err.Number = x Then
oRng.Value = sFDR & sItem
oRng.Offset(0, 1).Value = "Inaccessible folder"
Resume Next
End If
But this code doesn't work. It doesn't specify the path of the 'access denied' folder at all. Instead, it puts the text "Inaccessible folder" to the next accessible excel file it sees.
Here's the code:
Private Const FILE_FILTER = "*.xl*"
Private Const sRootFDR = "Path" ' 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
' List the files of this Directory
ListFiles sFDR, FILE_FILTER
' Recurse into each Sub Folder
On Error GoTo Handler
Handler:
If Err.Number = 5 Then
oRng.Value = sFDR & sItem
oRng.Offset(0, 1).Value = "Inaccessible folder"
Resume Next
End If
For Each oFDR In oFSO.GetFolder(sFDR).SubFolders
ListFolder oFDR.Path & "\" ' Need '\' to ensure the file filter works
Next
End Sub
Private Sub ListFiles(ByVal sFDR As String, ByVal sFilter As String)
Dim sItem As String
On Error GoTo Handler
Handler:
If Err.Number = 52 Then
oRng.Value = sFDR & sItem
oRng.Offset(0, 1).Value = "Inaccessible folder"
Resume Next
End If
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
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

Answer 1

Hum, I tried debugging your code and found the following.
Your error handlers are coded a bit goofy. If the handler gets triggered, yet the error code is NOT the one you are testing for, then you will re-invoke the loop from start. It would be more clean to code them as:
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 folder - access denied"
End If
Resume Next
End Sub
This ensures you perform a Resume Next for all errors that trigger the handler, not just the one error you are looking for. I know for the ListFiles() sub, that re-entrance into the loop should work properly, but still it is bad form. And that code format does not work for the ListFolder() sub as it causes hard aborts.
When I changed your ListFolder as shown (and changed Err.Number checked for to 70), you code seems to work for me. I made both inaccessible files and folders, and the proper error tag was shown with the proper file names and directory names that I made inaccessible.