Обработка ошибок Excel VBA с отказом в доступе при доступе к папке / файлу

Question

Я пишу скрипт, который просматривает определенный каталог файлов, а затем записывает все папки в этом месте, а также дату последнего редактирования. Однако все работает так, как ожидалось, если он сталкивается с файлом, для которого у меня нет прав доступа (ошибка времени выполнения «70»: разрешение отклонено).

Я плохо разбираюсь в обработке ошибок, и, попробовав кучу вещей, о которых я мог подумать, и проведя некоторое исследование, я все еще в тупике, я бы хотел, чтобы, если есть файл, к которому он не может получить доступ из-за разрешений, он либо просто пропускает его, либо идеальный мир окрашивает его в красный цвет или что-то еще в выводе, а затем переходит к следующему в списке.

      Sub ListFoldersInDirectory()

'Application.ScreenUpdating = False

    Dim objFSO, objFolders, objFolder As Object
    Dim strDirectory, arrFolders(), test, a, LocationPath As String
    Dim FolderCount, FolderIndex, getdirorfilesize, oFO As Long
    Dim b, c As Integer

 On Error Resume Next
    If Err.number <> 0 Then
        If Err.number = 70 Then
            MsgBox "Permission Denied"
        'Else
            'MsgBox "An error occurred..."
        End If
        Err.Clear
    End If
    On Error GoTo 0
    
Sheets(2).Activate

'First time run to paste the first data in the correct place
Do While Sheets(2).Range("N1").Value = 0
Sheets(2).Range("N1").Value = 1

'Opens file directory and lets you select inital folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Select Folder"
        .Show
        If .SelectedItems.Count = 0 Then
            Exit Sub
        End If
        strDirectory = .SelectedItems(1)
    End With
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolders = objFSO.GetFolder(strDirectory).Subfolders
    
    FolderCount = objFolders.Count
    
    'Checks what folders are in the specified folder then pastes them onto asheet
    If FolderCount > 0 Then
        ReDim arrFolders(1 To FolderCount)
        FolderIndex = 0
        For Each objFolder In objFolders
            FolderIndex = FolderIndex + 1
            arrFolders(FolderIndex) = objFolder.Name
        Next objFolder
        Sheets(1).Range("A1").Resize(FolderCount).Value = Application.Transpose(arrFolders)
        
        'Changes pasted data into a file address
        Sheets(1).Activate
        Sheets(1).Range("A1").Select
        Selection.End(xlDown).Select
        a = ActiveCell.Address
        Sheets(1).Range("A1:" & a).Select
            For Each x In Selection
            x.Activate
            ActiveCell.FormulaR1C1 = strDirectory & "\" & ActiveCell.Formula
            Next x
     
    'Moves Data to the main sheet
    Sheets(1).Activate
    Sheets(1).Range("A1").Select
    Selection.End(xlDown).Select
    b = ActiveCell.Row
            
    Range("A1:A" & b).Select
    Selection.Cut
    Sheets(2).Select
    Range("a1").Select
    'Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste

'Retrieves time and date when file was last accessed
            Sheets(2).Activate
        Sheets(2).Range("A1").Select
        Selection.End(xlDown).Select
        a = ActiveCell.Address
        Sheets(2).Range("A2:" & a).Select
        For Each x In Selection
            x.Activate
            LocationPath = ActiveCell.Value
            ActiveCell.Offset(0, 1).FormulaR1C1 = _
        FileDateTime(LocationPath)
            Next x
    Else
        MsgBox "No folders found!", vbExclamation
    End If

Loop


    Set objFSO = Nothing
    Set objFolders = Nothing
    Set objFolder = Nothing
    
    'Application.ScreenUpdating = True

    'GetSubFolders

End Sub

Как вы можете видеть вверху, это попытка заставить что-то произойти, когда возникает ошибка, хотя и безуспешно, если это помогает, часть, выделенная в отладчике, называется «FolderCount = objFolders.Count».

Извиняюсь за беспорядочный код, как только все заработает, я планировал все почистить!