VBA程序：列出文件夹及其子文件夹中的指定文件

Sub test()
 Dim lst As ListBox
 Dim i As Long
 
 ListFiles "C:\Users\excelperfect\Desktop\未完成", "*st.xls*", True, lst
 On Error Resume Next
 For i = 0 To lst.ListCount - 1
   Debug.Print lst.List(i).Value
 Next
End Sub

'目的: 列出路径中的文件.
'参数: strPath = 要搜索的路径.
' strFileSpec = "*.*" 除非另有指定.
' bIncludeSubfolders: 如果为True,同时从strPath的子文件夹中返回结果.
' lst: 如果传递到列表框, 则在其中添加项. 如果不, 则将文件在立即窗口列出.
' 列表框必须具有其Row Source Type属性设置为Value列表.
'方法:FilDir()添加项到集合, 对子文件夹递归调用自身.
Public Function ListFiles(ByVal strPath As String, Optional ByVal strFileSpec As String = "*.*", _
 Optional ByVal bIncludeSubfolders As Boolean = False, Optional ByRef lst As ListBox = Nothing)
 On Error GoTo Err_Handler

 Dim colDirList As New Collection
 Dim varItem As Variant

 Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders)

 '如果传入，将其添加到列表框中.否则,将列表添加到即时窗口中.
 If lst Is Nothing Then
   For Each varItem In colDirList
     Debug.Print varItem
     DoEvents
   Next
 Else
   For Each varItem In colDirList
     lst.AddItem varItem
   Next
 End If
Exit_Handler:
 Exit Function
Err_Handler:
 MsgBox "错误 " & Err.Number & ": " & Err.Description
 Resume Exit_Handler
End Function

Private Function FillDir(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, _
 bIncludeSubfolders As Boolean)
 '创建文件列表, 然后添加到该列表
 Dim strTemp As String
 Dim colFolders As New Collection
 Dim vFolderName As Variant
 On Error Resume Next
 '添加文件到文件夹.
 strFolder = TrailingSlash(strFolder)
 strTemp = Dir(strFolder & strFileSpec)
 Do While strTemp <> vbNullString
   colDirList.Add strFolder & strTemp
   strTemp = Dir
 Loop
 If bIncludeSubfolders Then
   '建立另外子文件夹的集合.
   strTemp = Dir(strFolder, vbDirectory)
   Do While strTemp <> vbNullString
     If (strTemp <> ".") And (strTemp <> "..") Then
       If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
         colFolders.Add strTemp
       End If
     End If
     strTemp = Dir
   Loop
   '对每个子文件夹递归调用函数.
   For Each vFolderName In colFolders
     Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
   Next vFolderName
 End If
End Function

Public Function TrailingSlash(varIn As Variant) As String
 If Len(varIn) > 0& Then
   If Right(varIn, 1&) = "\" Then
     TrailingSlash = varIn
   Else
     TrailingSlash = varIn & "\"
   End If
 End If
End Function