请各位老师指教：《循环遍历文件夹》宏（通用）

413191246se · 发表于 2019-6-9 14:17

* 据网文称，VBA遍历文件夹常用有三种方法，这三种方法中,filesearch不适合2007和2010版本，而且速度比较慢；递归法FSO速度也慢；只有用DIR加循环（+双字典+数组）的方法，速度飞快。
* 我决定抛弃 Word2003 的 FileSearch 法，FSO法也慢也不用，采用 Dir + 循环 + 双字典 + 数组的方法。
* 从网上找了一段代码，原作者是 kiddragon，在此表示感谢！虽然不懂字典、数组，但我仍做了一些修改。
* 下面的代码在 Word2007/2003 中测试通过，运行正常（测试了包含 25 个文件和 62 个文件的文件夹）！
——请各位老师、朋友指教，是否还有更好、更快的方法？

Sub LoopDir循环遍历文件夹()
On Error Resume Next
Dim objShell As Object
Dim objFolder As Object
Dim SearchPath As String
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "请选择文件夹！", 0, 0)
SearchPath = objFolder.self.Path & ""
If MsgBox("请确认！是否处理文件夹 " & SearchPath & " ?", 4 + 16) = vbNo Then Exit Sub
Set objShell = Nothing
Set objFolder = Nothing
Dim DicList As Object
Dim FileList As Object
Dim Key
Dim NowDic As String
Dim NowFile As String
Dim i As Long
Dim FileName, FilePath
Set DicList = CreateObject("Scripting.Dictionary")
Set FileList = CreateObject("Scripting.Dictionary")
DicList.Add SearchPath, ""
i = 0
Do While i < DicList.Count
Key = DicList.keys
NowDic = Dir(Key(i), vbDirectory)
Do While NowDic <> ""
If (NowDic <> ".") And (NowDic <> "..") Then
If (GetAttr(Key(i) & NowDic) And vbDirectory) = vbDirectory Then DicList.Add Key(i) & NowDic & "", ""
End If
NowDic = Dir()
Loop
i = i + 1
Loop
For Each Key In DicList.keys
NowFile = Dir(Key)
Do While NowFile <> ""
FileList.Add NowFile, Key
NowFile = Dir()
Loop
Next
Dim doc As Document
Dim x&
i = 0
FileName = FileList.keys
FilePath = FileList.Items
Do While i < FileList.Count
If FilePath(i) & FileName(i) Like "*.doc*" Then
Set doc = Documents.Open(FileName:=FilePath(i) & FileName(i), Visible:=False)
doc.Content.Font.Color = wdColorRed '单个文档处理
doc.Close SaveChanges:=wdSaveChanges
x = x + 1
End If
i = i + 1
Loop
Set DicList = Nothing
Set FileList = Nothing
MsgBox "文件夹包含 " & i & " 个文件！" & vbCr & "共处理 Word 文档(*.docx/*.doc) " & x & " 个！", 0 + 48
End Sub

复制代码

413191246se · 发表于 2019-6-9 14:19

* 原作者 kiddragon 代码：

Sub 循环遍历文件夹及子文件夹_显示所有文件的文件名()
'Code by kiddragon
'TEST-OK/2019-6-8
Dim Key, NowDic, NowFile
Const SearchPath = "E:\LoopDir"
Dim DicList, FileList, i, FileName, FilePath
Set DicList = CreateObject("Scripting.Dictionary")
Set FileList = CreateObject("Scripting.Dictionary")
DicList.Add SearchPath, "" '初始化目录
'遍历所有目录并添加到DicList
i = 0
Do While i < DicList.Count
Key = DicList.keys '本次要遍历的目录
NowDic = Dir(Key(i), vbDirectory) '开始查找
Do While NowDic <> ""
If (NowDic <> ".") And (NowDic <> "..") Then
If (GetAttr(Key(i) & NowDic) And vbDirectory) = vbDirectory Then
'找到子目录，则添加
DicList.Add Key(i) & NowDic & "", ""
End If
End If
NowDic = Dir() '再找
Loop
i = i + 1
Loop
'遍历目录中的所有文件并将其添加到FileList中，FileList.Key=文件名,FileList.Item=目录
For Each Key In DicList.keys '查找所有目录中的文件
'MsgBox key
NowFile = Dir(Key)
Do While NowFile <> ""
'MsgBox NowFile
FileList.Add NowFile, Key 'Add(Key,Item) FileList.Key=文件名,FileList.Item=目录
NowFile = Dir()
Loop
Next
i = 0
FileName = FileList.keys
FilePath = FileList.Items
Do While i < FileList.Count
'弹出所有查询到的文件字符串
MsgBox FilePath(i) & FileName(i)
i = i + 1
Loop
End Sub

复制代码

413191246se · 发表于 2019-6-9 14:23

本帖最后由 413191246se 于 2019-6-9 14:26 编辑

* 各位朋友们，如果有想循环遍历文件夹及子文件夹的要求，可以使用 1 楼代码，但请注意：第 60 行代码要自行修改（单个文档处理，自定义单个文档的格式处理即可，其它的不用管）。
* 如果采用 1 楼代码，请事先做好文件备份，以免造成损失，谢谢！

duquancai · 发表于 2019-6-9 14:49

本帖最后由 duquancai 于 2019-6-9 20:37 编辑

编程不学function，真是悲哀！不学class，当然也是悲哀！
话说:“只有用DIR加循环（+双字典+数组）的方法，速度飞快。”请问：这个结论从何而来？

小花鹿 · 发表于 2019-6-9 19:59

作者阿杜：
Sub FSO_提取全路径文件()
Dim f As Object, fd As Object, fso As Object, Stack$(), top&
With Application.FileDialog(msoFileDialogFolderPicker)
      If .Show Then pPath$ = .SelectedItems(1) Else MsgBox "请选目标文件夹": Exit Sub
End With
Set fso = CreateObject("Scripting.FileSystemObject")
top = 1: ReDim Stack(0 To top)
Do While top >= 1
      For Each f In fso.GetFolder(pPath).Files
         n = n + 1
         stxt = stxt & f.Path & Chr(13)
      Next
      For Each fd In fso.GetFolder(pPath).SubFolders
         Stack(top) = fd.Path: top = top + 1
         If top > UBound(Stack) Then ReDim Preserve Stack(0 To top)
      Next
      If top > 0 Then pPath = Stack(top - 1): top = top - 1
Loop
ActiveDocument.Content.Text = Empty
ActiveDocument.Content.Text = stxt
MsgBox "已提取：" & n & "个包含选择路径下的所有文件！"
End Sub

413191246se · 发表于 2019-6-9 20:46

本帖最后由 413191246se 于 2019-6-9 21:05 编辑

杜老师：我不会的很多，如：函数、数组、字典、FSO、类……等，好多好多，关键是，本人天资还很愚笨。“DIR + 循环”速度飞快，是网文上说的，我就信了，反正我也不会。现在，我用 VBA 查找和替换，还算有些心得，其它的真不会。虽然我常常幻想能达到微软软件工程师那个水平，想编啥编啥。

小花鹿老师：谢谢提供代码，我要做一下比较（VS），和我 1 楼代码比比。FSO 也好，DIR 循环也好，都不懂，我只好凭实际测试结果来采纳。

两位老师，现在我一维数组，都不大会，也会一点，反正稀里糊涂的。

*******************
前几天，安装上了 Office2007，仍然保留 Office2003，现在可以两个都使用，但我现在偏爱 Word2007（我也只用 Word，其它组件均不使用）。以前也安装过几次 Office2007，但都卸载了；另外，发现 Word2007 其实也经常崩溃，和 Word2003 没啥大区别。

昨晚我想，Word2007 是不是在 Word2003 的基础上，多了一个 Ribbon 界面而已呢？

我过去曾经安装过 VB6.0，但没怎么学会编程，连《计算器》都不会编。后来在会录制宏的基础上，在2011年6月间突然开窍，知道进 VBE 编辑代码了！以前不会，其实在 VB6.0 中我已经见过 VBE。在 2011年7月进本坛，直到现在已有 8 年了，有些进步，但进步不大。这两年，跟杜老师学习了一些《方法/属性》及代码简写的一些知识，进步较大。

谢谢两位老师回复！并请时常指教。——杜老师，我今晚就要学一学 Function。

413191246se · 发表于 2019-6-10 01:21

duquancai · 发表于 2019-6-10 08:43

不懂function，不懂class，不懂数据结构与算法，去谈效率纯属扯淡！

413191246se · 发表于 2019-6-10 10:09

谢谢杜老师批评指正！有空我要学学函数，但现在我还是想把自动排版宏（通用模板宏）重新搞一搞。
搞一个通用于 2007和 2003 之间的唯一的一个。

		自动登录	找回密码
密码			免费注册

[讨论] 请各位老师指教：《循环遍历文件夹》宏（通用）