遍历所有子文件夹枚举指定类型文件或文件夹的函数

孤独行星双星记

谢谢分享，可以参考一下。

wangqing208

感谢楼主分享，目前工作正遇到类似情景呢

香川群子

有个小错误需要纠正一下：

第5行：If Left(MuLu, 1) <> "\" Then MuLu = MuLu & "\"

正确的应该是Right：

If Right(MuLu, 1) <> "\" Then MuLu = MuLu & "\"


作用是，如果路径最后一个字符不是目录符号"\"就添一个"\"上去。

香川群子

Eutopian 发表于 2011-11-25 21:49
前段時間我也試著做了個找文件夾的過程(只是單單列出磁盤上所有normal屬性的文件夾, 不考慮檢索文件), 希望 ...

你的想法写成代码了么？

…………
我前几天写了一个FSO的，是用递归处理的，效果很不错。

但是FSO方法，比Dir方法要慢。

呵呵。

香川群子

veggieg 发表于 2012-2-13 20:42
我水平低下~~看不懂啊~~

哪位好心人讲解下吗 ^^

是每一句都看不懂，还是某一句、某几句看不懂？


…………如果没一句看懂的，那就算了。等有了些基础再说吧。

香川群子

cg1 发表于 2011-11-22 12:43
原因是文件中只要包含 非 GB2312 字符就出错。

正解！

需要容错处理。

Public Function ListFile(MuLu As String, Zi As Boolean, Optional LeiXing As String = "")
    Dim MyFile As String, ms As String
    Dim arr, brr, x
    Dim i As Integer
    Set d = CreateObject("Scripting.Dictionary")
    If Right(MuLu, 1) <> "\" Then MuLu = MuLu & "\"
    d.Add MuLu, ""
    i = 0
   
    On Error Resume Next '这里增加错误时继续的处理代码
    Do While i < d.Count
        brr = d.keys
        MyFile = Dir(brr(i), vbDirectory)
        Do While MyFile <> ""
            If MyFile <> "." And MyFile <> ".." Then
                If (GetAttr(brr(i) & MyFile) And vbDirectory) = vbDirectory Then
                    If Err.Number Then '这里增加文件名字符错误处理判断
                        Err.Clear '#52 文件名错误
                    Else
                        d.Add (brr(i) & MyFile & "\"), ""
                    End If
                End If
            End If
            MyFile = Dir
        Loop
        If Zi = False Then Exit Do
        i = i + 1
    Loop
    If LeiXing = "" Then
        ListFile = Application.Transpose(d.keys)
    Else
        For Each x In d.keys
            MyFile = Dir(x & LeiXing)
            Do While MyFile <> ""
                ms = ms & x & MyFile & ","
                MyFile = Dir
            Loop
            If Zi = False Then Exit For
        Next
        If ms = "" Then ms = "没有符合要求的文件,"
        ListFile = Application.Transpose(Split(ms, ","))
    End If
End Function

wolfanong

学习，谢谢分享

Eutopian

香川群子 发表于 2013-4-22 20:55
你的想法写成代码了么？

…………

當時正在學習到FOS對象, 在論壇上看到這個帖子, 一時也想試試, 於是也寫了一段代碼. 最初也嘗試過用遞歸的方法, 不過還是個新手, 不會用, 而且在處理不斷新發現的子文件夾的問題上有點混亂, 後來想來想去, 才想了這麽一個方法. 在碰到C盤上的一些windows禁止訪問的系統文件夾時會出錯, 一直沒有辦法解決, 最後祇有避開C盤了, 見附件, 請多多指點!

香川群子

Eutopian 发表于 2013-4-25 20:56
當時正在學習到FOS對象, 在論壇上看到這個帖子, 一時也想試試, 於是也寫了一段代碼. 最初也嘗試過用遞歸的 ...

递归其实很简单。比一般代码过程更简单。

请看下面例子：
用FSO方法遍历指定路径下所有文件夹，查找文件名中含某个字符的文件。

1. Dim s$, fNm$ '定义公共变量：关键词s和文件名结果fNm
   
2. 
   
3. Sub FindFile()
   
4.     s = InputBox("Input key word:", "Find Files", s) '输入要查找的文件名中的关键词
   
5.     If s = "" Then Exit Sub
   
6.     pth = InputBox("Confirm FileFolder Path:", "Find Files", ThisWorkbook.Path) '输入路径
   
7.    
   
8.     fNm = "": tms = Timer '文件名结果fNm变量的初始化
   
9.     Call FindFileName(pth) '调用递归过程
   
10.     MsgBox Format(Timer - tms, "0.000s ")
    
11. '    Workbooks.Open filename:=fNm '打开这个文件或做其它事
    
12.    
    
13. End Sub
    
14. 
    
15. Sub FindFileName(pth)
    
16.     If fNm <> "" Then Exit Sub '找到以后就结束递归过程（如果要找到全部则这一句注释掉）
    
17.    
    
18.     Set fso = CreateObject("Scripting.FileSystemObject") '设置fso对象
    
19.     Set fld = fso.GetFolder(pth) '设置fso对象的父文件夹fld
    
20.     Set fsb = fld.SubFolders '设置fso对象文件夹下的子文件夹fsb
    
21.     For Each fd In fsb '遍历所有子文件夹
    
22.         For Each f In fd.Files '遍历每个子文件夹中的所有文件
    
23.             If InStr(f.Name, s) Then fNm = fd.Path & "" & f.Name: Exit Sub
    
24.             '找到符合关键词的文件后退出（或者可以存入数组内然后继续查找所有符合的文件）
    
25.         Next
    
26.         Call FindFileName(fd.Path) '该子文件夹遍历结束时，继续递归进入该文件夹的子文件夹搜寻……
    
27.     Next
    
28. End Sub
    

复制代码

呵呵，特别简单吧。

香川群子

Eutopian 发表于 2013-4-25 20:56
當時正在學習到FOS對象, 在論壇上看到這個帖子, 一時也想試試, 於是也寫了一段代碼. 最初也嘗試過用遞歸的 ...

下面是搜寻并列出所有符合条件的文件的递归代码：

1. Public flist$(65535, 3), fc&, fs&, k&, s$
   
2. 
   
3. Sub FileList()
   
4.    
   
5.     s = InputBox("Please input File's Ext type:", "Find Files", "xl")
   
6.     If s = "" Then Exit Sub Else s = LCase(s) & "*"
   
7.     pth = InputBox("Confirm FileFolder Path:", "Find Files", ThisWorkbook.Path)
   
8.    
   
9.     k = 0: fc = 0: fs = 0: tms = Timer
   
10.     Set fso = CreateObject("Scripting.FileSystemObject")
    
11.     Set fld = fso.GetFolder(pth)
    
12.     t = 0
    
13.     For Each f In fld.Files
    
14.         n = InStrRev(f.Name, ".")
    
15.         If n Then
    
16.             x = LCase(Mid(f.Name, n + 1))
    
17.             If x Like s Then
    
18.                 t = 1
    
19.                 flist(k, 0) = x
    
20.                 flist(k, 1) = f.Name
    
21.                 flist(k, 2) = fld.Name
    
22.                 flist(k, 3) = fld.Path
    
23.                 k = k + 1
    
24.             End If
    
25.         End If
    
26.     Next
    
27.     If t Then fs = fs + 1
    
28.     fc = fc + 1
    
29.     Call GetFolderFile(pth)
    
30.    
    
31.     [a1].CurrentRegion.Offset(1) = ""
    
32.     If k Then [a2].Resize(k, 4) = flist
    
33.     [b1] = "Check " & fc & " SubFolders Get " & k & " Files from " & fs & " Folders."
    
34.     MsgBox Format(Timer - tms, "0.000s")
    
35.    
    
36. End Sub
    
37. 
    
38. Function GetFolderFile(pth)
    
39.     Set fso = CreateObject("Scripting.FileSystemObject")
    
40.     Set fld = fso.GetFolder(pth)
    
41.     Set fsb = fld.SubFolders
    
42.     For Each fd In fsb
    
43.         t = 0
    
44.         For Each f In fd.Files
    
45.             n = InStrRev(f.Name, ".")
    
46.             If n Then
    
47.                 x = LCase(Mid(f.Name, n + 1))
    
48.                 If x Like s Then
    
49.                     t = 1
    
50.                     flist(k, 0) = x
    
51.                     flist(k, 1) = f.Name
    
52.                     flist(k, 2) = fd.Name
    
53.                     flist(k, 3) = fd.Path
    
54.                     k = k + 1
    
55.                 End If
    
56.             End If
    
57.         Next
    
58.         If t Then fs = fs + 1
    
59.         fc = fc + 1: Call GetFolderFile(fd.Path)
    
60.     Next
    
61. End Function
    

复制代码

递归的做法其实是一样的。