Excel 宏vba列出所有不可访问的网络文件夹

我有一个vba代码，可以扫描文件夹及其子目录中的excel文件，并列出连接字符串和sql命令。但我的问题是我的程序没有列出不可访问的网络文件夹，这会导致错误“拒绝访问”。我希望能够列出文件夹的路径，并在第二列中指出该文件夹不可访问。我应该如何编码？我在想

    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

但是这个代码不起作用。它根本没有指定“拒绝访问”文件夹的路径。相反，它将文本“不可访问的文件夹”放在它看到的下一个可访问的excel文件中

代码如下：

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

---

嗯，我试着调试你的代码，发现了以下内容

您的错误处理程序编码有点愚蠢。如果处理程序被触发，但错误代码不是您要测试的代码，那么您将从一开始重新调用循环。将它们编码为：

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

这将确保您针对触发处理程序的所有错误执行恢复，而不仅仅是您正在查找的一个错误。我知道对于ListFiles（）子类，重新进入循环应该可以正常工作，但它仍然是一种糟糕的形式。并且该代码格式不适用于ListFolder（）子文件，因为它会导致硬中止

当我如图所示更改您的ListFolder（并将检查的错误号更改为70）时，您的代码似乎适合我。我设置了不可访问的文件和文件夹，并显示了正确的错误标记以及我设置为不可访问的正确文件名和目录名