[VBA][开发]取得文件夹及所有子文件夹中的文件列表

oudaisei

写了一个[取得文件夹及所有子文件夹中的文件列表]的处理，与大家共享。
请多多指正。

1. 
   
2. Function getFilesFromDirectory(directoryName As String _
   
3.                               , Optional filePattern As String = "*" _
   
4.                               , Optional allowSubDirectory As Boolean = False _
   
5.                               ) As Collection
   
6.     Dim directories As New Collection
   
7.     Dim baseDirectory As String, pathName As String, fullPath As String
   
8.    
   
9.     Set getFilesFromDirectory = New Collection
   
10.    
    
11.     baseDirectory = directoryName
    
12.     If (Right(baseDirectory, 1) <> "") Then
    
13.         baseDirectory = baseDirectory + ""
    
14.     End If
    
15. 
    

复制代码

oudaisei

1.     directories.Add baseDirectory
   
2.     If allowSubDirectory Then
   
3.         Dim i As Long
   
4.         i = 1
   
5.         Do While (i <= directories.count)
   
6.             fullPath = directories.Item(i)
   
7.             pathName = Dir(fullPath, vbNormal + vbDirectory) 'vbNormal:0, vbDirectory:16
   
8.             Do While (Len(pathName) > 0)
   
9.                 fullPath = directories.Item(i) + pathName
   
10.                 If GetAttr(fullPath) And vbDirectory Then
    
11.                     If (pathName <> "." And pathName <> "..") Then
    
12.                         fullPath = directories.Item(i) + pathName & ""
    
13.                         directories.Add fullPath
    
14.                     End If
    
15.                 End If
    
16.                 pathName = Dir()
    
17.             Loop
    
18.             i = i + 1
    
19.         Loop
    
20.     End If
    
21. 
    
22.     Dim d As Variant
    
23.     For Each d In directories
    
24.         fullPath = d + filePattern
    
25.         pathName = Dir(fullPath, vbNormal)
    
26.         Do While (Len(pathName) > 0)
    
27.             fullPath = d + pathName
    
28.             getFilesFromDirectory.Add fullPath
    
29.             pathName = Dir()
    
30.         Loop
    
31.     Next
    
32. End Function

复制代码

oudaisei

好像帖子有长度限制，不能一次发全代码，不好意思了。

测试执行可用下面的代码

1. Sub test()
   
2.     Dim fNames As Collection
   
3.     Dim f As Variant
   
4.     Set fNames = getFilesFromDirectory(directoryName:="c:\test", filePattern:="*.xls*", allowSubDirectory:=True)
   
5.     For Each f In fNames
   
6.         Debug.Print f
   
7.     Next
   
8. End Sub

复制代码

tudarong

不错，给你点赞

qingc0221

不是吧,我之前有发过一两百行的代码,没见有限制啊

nmcfbgttyl

怎么运行到这句：If GetAttr(fullPath) And vbDirectory Then   提示  文件未找到

oudaisei

nmcfbgttyl 发表于 2018-6-25 14:45
怎么运行到这句：If GetAttr(fullPath) And vbDirectory Then   提示  文件未找到

将1楼代码12行，13行的双引号中加入路径分隔符\应该就可以了。
不知道为什么代码显示不出来。


    If (Right(baseDirectory, 1) <> "\") Then
        baseDirectory = baseDirectory + "\"
    End If

1. 
   
2.     If (Right(baseDirectory, 1) <> "") Then
   
3.         baseDirectory = baseDirectory + ""
   

复制代码

nmcfbgttyl

oudaisei 发表于 2018-6-25 21:40
将1楼代码12行，13行的双引号中加入路径分隔符\应该就可以了。
不知道为什么代码显示不出来。

还是提示  文件未找到，

我的实际路径不是“E：\20152015",而是“E：\2015"

YZC51

nmcfbgttyl 发表于 2018-8-7 15:14
还是提示  文件未找到，

我的实际路径不是“E：\20152015",而是“E：\2015"

'                If GetAttr(fullPath) And vbDirectory Then
修改为：
                If GetAttr(directoryName) And vbDirectory Then

02761752696

不错       谢谢分享