带有超链接的文件夹/子文件夹中的所有文件的列表

Question

我正在使用此代码列出文件夹和子文件夹中的文件。代码工作正常。但如果没有子文件夹，我会在下面的行中收到错误。

'Files under current dir
fname = Dir(fPath & "*." & fType). 

我想要空文件夹的消息框选项（是/否）。 （目前显示所有空文件夹）

Public oldNR As Long
Sub HyperlinkDirectory()

Dim fPath As String
Dim fType As String
Dim fname As String
Dim NR As Long
Dim AddLinks As Boolean

'Select folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
         .InitialFileName = "C:\2009\"
        .Show
        If .SelectedItems.Count > 0 Then
            fPath = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With

'Types of files
    fType = Application.InputBox("What kind of files? Type the file extension to collect" _
            & vbLf & vbLf & "(Example:  xls, doc, txt, pdf, *)", "File Type", "PDF", Type:=2)
    If fType = "False" Then Exit Sub

'Option to create hyperlinks
    AddLinks = MsgBox("Add hyperlinks to the file listing?", vbYesNo) = vbYes

'Create report
    Application.ScreenUpdating = False
    NR = 4
    With ActiveSheet
        .Range("A:C").Clear
        .[A2] = "LIST OF FILES"
        .[B2] = "Modified Date"

        Call FindFilesAndAddLinks(fPath, fType, NR, AddLinks)

        End With
        With ActiveSheet
          .Range("A:B").Columns.AutoFit
          .Range("B:B").HorizontalAlignment = xlCenter

        Range("B:B").Select
        Selection.NumberFormat = "d-mmm-yy  h:mm AM/pm"
        End With

        With ActiveSheet
        Range("A2").Select
        Selection.Font.Bold = True
        Range("B2").Select
        Selection.Font.Bold = True
        Columns("A:A").Select
        Selection.Font.Underline = xlUnderlineStyleNone
    End With

    Application.ScreenUpdating = True

End Sub

Private Sub FindFilesAndAddLinks(fPath As String, fType As String, ByRef NR As Long, AddLinks As Boolean)
Dim fname As String
Dim oFS As New FileSystemObject
Dim oDir


'Files under current dir
fname = Dir(fPath & "*." & fType)
With ActiveSheet

    'Write folder name
    .Range("A" & NR) = fPath
    .Range("A" & NR).Select
    If AddLinks Then .Hyperlinks.Add Anchor:=Selection, _
           Address:=fPath, _
            TextToDisplay:="FOLDER NAME:  " & "  " & UCase(Split(fPath, "\")(UBound(Split(fPath, "\")) - 1))
             Selection.Font.Bold = True
             Selection.Font.Size = 10
             Selection.Font.Name = "Arial"
             Selection.Font.Underline = xlUnderlineStyleNone
             With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With

    With Selection.Font
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
    End With

    NR = NR + 2

    Do While Len(fname) > 0

      'filename
        If .Range("A" & NR) <> "" Then Debug.Print "Overwriting " & NR
        .Range("A" & NR) = fname
              'modified
        .Range("B" & NR) = FileDateTime(fPath & fname)

      'hyperlink
        .Range("A" & NR).Select
        If AddLinks Then .Hyperlinks.Add Anchor:=Selection, _
            Address:=fPath & fname, _
            TextToDisplay:=fname

      'set for next entry
        NR = NR + 1
        fname = Dir
    Loop

    'Files under sub dir
    Set oDir = oFS.GetFolder(fPath)
    For Each oSub In oDir.SubFolders
        NR = NR + 1
        Call FindFilesAndAddLinks(oSub.Path & "\", fType, NR, AddLinks)
    Next oSub
End With

        ActiveWindow.DisplayGridlines = False

End Sub