循环遍历文件夹及子文件夹（宏）2020-8-9（定稿）

413191246se · 发表于 2020-8-7 23:14

本帖最后由 413191246se 于 2020-8-9 21:25 编辑

* 各位朋友：下面 5 个主程序分别是 cuanju 老师、gbgbxgb 老师、duquancai 老师、小花鹿老师和一位挪威人 Havrda 所编写的宏代码。
* 还有两个小程序，分别是我编写的单个文档示例代码《adoc》宏和我编写的《SelectFolder》函数。
* 如果想批量排版 Word 文档(*.docx/*.doc)，可以在《adoc》宏里修改代码，不要修改主程序，以免出错。
* 以下 5 个宏均在 Word2019 (根下10层子文件夹) 下测试通过，正确无误！（Word2007-2019 应该都可以。）
*（不可在 Word2003 下使用，因为过去我试过，无法运行。Word2003 可以使用挪威人所写的代码，似乎可以。）

Sub 循环遍历文件夹及子文件夹_DIR_cuanju()
Dim strFileFilter As String
Dim strFileName As String, strType As String
Dim StartFolder As String
Dim FolderList As Object, FileList As Object
Dim FolderName, arr1
Dim oD As Document, i&, x&, m&, n&
strFileFilter = "doc*"
Set FolderList = CreateObject("Scripting.Dictionary")
Set FileList = CreateObject("Scripting.Dictionary")
StartFolder = SelectFolder
FolderList.Add StartFolder, ""
Do While FolderList.Count > 0
For Each FolderName In FolderList.keys
strFileName = Dir(FolderName, vbDirectory)
Do While strFileName <> ""
If strFileName <> ".." And strFileName <> "." Then
If GetAttr(FolderName & strFileName) And vbDirectory Then
FolderList.Add FolderName & strFileName & "", ""
m = m + 1
Else
i = InStrRev(strFileName, ".")
strType = Right(strFileName, Len(strFileName) - i)
If strType Like strFileFilter Then
FileList.Add FolderName & strFileName, ""
End If
n = n + 1
End If
End If
strFileName = Dir
Loop
FolderList.Remove (FolderName)
Next
Loop
For Each arr1 In FileList.keys
Set oD = Documents.Open(arr1)
adoc
oD.Close True
x = x + 1
Next
Set FolderList = Nothing
Set FileList = Nothing
MsgBox "文件夹包含 " & n & " 个文件！" & m & " 个子文件夹！" & vbCr & "共处理 Word 文档(*.docx/*.doc) " & x & " 个！", 0 + 48
End Sub
Sub 循环遍历文件夹及子文件夹_DIR_gbgbxgb()
Dim d As Object, thePath$, theStr$, i&, j&, k&, doc As Document
thePath = SelectFolder
Set d = CreateObject("Scripting.Dictionary")
d(thePath) = ""
Do While i < d.Count
thePath = d.keys()(i)
theStr = Dir(thePath, vbDirectory)
Do While theStr <> ""
If theStr <> "." And theStr <> ".." Then
If (GetAttr(thePath & theStr) And vbDirectory) = vbDirectory Then
d(thePath & theStr & "") = ""
Else
j = j + 1
If thePath & theStr Like "*.doc*" Then
Set doc = Documents.Open(FileName:=thePath & theStr)
adoc
doc.Close savechanges:=wdSaveChanges
k = k + 1
End If
End If
End If
theStr = Dir
Loop
i = i + 1
Loop
Set d = Nothing
MsgBox "文件夹包含 " & j & " 个文件！" & i - 1 & " 个子文件夹！" & vbCr & "共处理 Word 文档(*.docx/*.doc) " & k & " 个！", 0 + 48
End Sub
Sub 循环遍历文件夹及子文件夹_DIR_xiaohualu()
Dim d, n&, m&, x&, mydir, dk, doc As Document, i&
Set d = CreateObject("Scripting.Dictionary")
d(SelectFolder) = ""
Do While n < d.Count
dk = d.keys
mydir = Dir(dk(n), vbDirectory)
Do While mydir <> ""
If mydir <> "." And mydir <> ".." Then
If GetAttr(dk(n) & mydir) = vbDirectory Then
d(dk(n) & mydir & "") = ""
m = m + 1
Else
x = x + 1
If dk(n) & mydir Like "*.doc*" Then
Set doc = Documents.Open(FileName:=dk(n) & mydir)
adoc
doc.Close savechanges:=wdSaveChanges
i = i + 1
End If
End If
End If
mydir = Dir
Loop
n = n + 1
Loop
Set d = Nothing
Set dk = Nothing
MsgBox "文件夹包含 " & x & " 个文件！" & m & " 个子文件夹！" & vbCr & "共处理 Word 文档(*.docx/*.doc) " & i & " 个！", 0 + 48
End Sub
Sub 循环遍历文件夹及子文件夹_FSO_duquancai()
Dim pPath$, f As Object, fd As Object, fso As Object, Stack$(), top&, n&, stxt$, doc As Document, x&
pPath = SelectFolder
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 = f.Path
If stxt Like "*.doc*" Then
Set doc = Documents.Open(FileName:=stxt)
adoc
doc.Close savechanges:=wdSaveChanges
x = x + 1
End If
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
Set f = Nothing
Set fd = Nothing
Set fso = Nothing
MsgBox "文件夹包含 " & n & " 个文件！" & vbCr & "共处理 Word 文档(*.docx/*.doc) " & x & " 个！", 0 + 48
End Sub
Sub adoc()
With ActiveDocument.Paragraphs(1).Range
.InsertBefore Text:="Loop Folders!" & vbCr
.Bold = True
.Underline = wdUnderlineSingle
.Font.ColorIndex = wdRed
.ParagraphFormat.Alignment = wdAlignParagraphJustify
End With
End Sub
Function SelectFolder() As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then SelectFolder = .SelectedItems(1) & "" Else End
End With
If MsgBox("是否选择文件夹 " & """" & SelectFolder & """" & " ?", 4 + 16) = vbNo Then End
End Function
Sub 循环遍历文件夹及子文件夹_DIR_Havrda()
Dim n&, doc As Document
Dim FileNameWithPath As Variant, ListOfFilenamesWithParh As New Collection
Call FileSearchByHavrda(ListOfFilenamesWithParh, SelectFolder, "*.doc*", True)
For Each FileNameWithPath In ListOfFilenamesWithParh
Set doc = Documents.Open(FileName:=FileNameWithPath)
adoc
doc.Close savechanges:=wdSaveChanges
n = n + 1
Next FileNameWithPath
If ListOfFilenamesWithParh.Count = 0 Then MsgBox "File not found!"
MsgBox "处理完毕！共处理 Word 文档(*.docx/*.doc) " & n & " 个！", 0 + 48
End Sub
Sub FileSearchByHavrda(pFoundFiles As Collection, pPath As String, pMask As String, pIncludeSubdirectories As Boolean)
Dim DirFile As String, CollectionItem As Variant, SubDirCollection As New Collection
pPath = Trim(pPath)
If Right(pPath, 1) <> "" Then pPath = pPath & ""
DirFile = Dir(pPath & pMask)
Do While DirFile <> ""
pFoundFiles.Add pPath & DirFile
DirFile = Dir
Loop
If Not pIncludeSubdirectories Then Exit Sub
DirFile = Dir(pPath & "*", vbDirectory)
Do While DirFile <> ""
If DirFile <> "." And DirFile <> ".." Then
If ((GetAttr(pPath & DirFile) And vbDirectory) = 16) Then SubDirCollection.Add pPath & DirFile
End If
DirFile = Dir
Loop
For Each CollectionItem In SubDirCollection
Call FileSearchByHavrda(pFoundFiles, CStr(CollectionItem), pMask, pIncludeSubdirectories)
Next
End Sub

复制代码

小花鹿 · 发表于 2020-8-8 07:23

Sub 遍历子文件夹()
Dim d, thispath, thisname, n&, m&, x&, mydir, dk
Set d = CreateObject("scripting.dictionary")
thispath = ThisWorkbook.Path & "\"
thisname = ThisWorkbook.Name
d(thispath) = ""
Do While n < d.Count
dk = d.keys
mydir = Dir(dk(n), vbDirectory)
Do While mydir <> ""
      If mydir <> "." And mydir <> ".." Then
         If GetAttr(dk(n) & mydir) = vbDirectory Then
            d(dk(n) & mydir & "\") = ""
            m = m + 1
            Cells(m, 1) = dk(n) & mydir & "\"
         Else
            x = x + 1
            Cells(x, 7) = dk(n) & mydir
         End If
      End If
      mydir = Dir
Loop
n = n + 1
Loop
End Sub

约定的童话 · 发表于 2020-8-8 08:43

小花鹿发表于 2020-8-8 07:23
Sub 遍历子文件夹()
Dim d, thispath, thisname, n&, m&, x&, mydir, dk
Set d = CreateObject("scriptin ...

此法甚是精湛啊，学习了

413191246se · 发表于 2020-8-8 11:06

本帖最后由 413191246se 于 2020-8-8 19:52 编辑

* 小花鹿老师：辛苦了！多谢！——待我改为 for Word 格式。。。刚才测试了一下，似乎很完美！我再细细完备之。。。

loquat · 发表于 2020-8-8 12:23

dir函数对unicode字符串支持不好

413191246se · 发表于 2020-8-8 13:30

谢谢 loquat 老师！——我大略地测试了一下 duquancai 杜老师的代码，似乎还好，都修改格式并保存了。
老师，那针对 Unicode 有什么好对策没有呢？

小花鹿 · 发表于 2020-8-8 21:17

FSO加递归的方法：
Sub test()
Dim fso, fld, f, br(1 To 65536, 1 To 1), n&
Set fso = CreateObject("scripting.filesystemobject")
Set fld = fso.getfolder(ThisWorkbook.Path)
For Each f In fld.Files
n = n + 1
br(n, 1) = f
Next f
Call digui(br, n, ThisWorkbook.Path)
[a1].Resize(n) = br
End Sub
Sub digui(br, n, p)
Dim fso, fld, f, subfld, fd
Set fso = CreateObject("scripting.filesystemobject")
Set fld = fso.getfolder(p)
Set subfld = fld.subfolders
For Each fd In subfld
For Each f In fd.Files
n = n + 1
br(n, 1) = f
Next f
Call digui(br, n, fd)
Next fd
End Sub

413191246se · 发表于 2020-8-8 23:17

小花鹿老师：又辛苦您了！您的 2 楼代码我已经改写完毕，完美无缺，正确无误！7 楼代码明日测试。

cuanju · 发表于 2020-8-9 09:04

本帖最后由 cuanju 于 2020-8-9 11:25 编辑

Sub dm1()
Rem 提取文件夹的所有全文件名及文件大小
Rem 可以通过修改代码实现遍历文件夹（不遍历子文件夹）或遍历子文件夹
Dim Fso As Object, arr$(), i&, sPath$
Set Fso = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
      If .Show = True Then sPath = .SelectedItems(1) & "\" Else Exit Sub
End With
Call GetFiles(sPath, Fso, arr, i)
ActiveSheet.UsedRange.Clear
ActiveSheet.Range("A2").Resize(i, 2) = Application.Transpose(arr)
ActiveSheet.Cells(1, 1).Value = "文件名"
ActiveSheet.Cells(1, 2).Value = "大小(MB)"
ActiveSheet.Range("B:B").NumberFormatLocal = "#,##0.00_ "
ActiveSheet.Columns("A:B").AutoFit
ActiveSheet.Range("A1").CurrentRegion.Sort key1:=Range("B1"), Order1:=xlDescending, Header:=xlYes '排序
End Sub

Private Sub GetFiles(ByVal sPath$, ByRef Fso As Object, ByRef arr$(), ByRef i&)
Dim Folder As Object
Dim SubFolder As Object
Dim File As Object
Set Folder = Fso.GetFolder(sPath)
For Each File In Folder.Files
      i = i + 1
      If i = 1 Then
         ReDim arr(1 To 2, 1 To 1)
      Else
         ReDim Preserve arr(1 To 2, 1 To i)
      End If
      arr(1, i) = File.Path
      arr(2, i) = File.Size / 1048576
Next
'如果不提取子文件夹下的文件则注释掉以下三行代码
For Each SubFolder In Folder.SubFolders
      Call GetFiles(SubFolder.Path, Fso, arr, i)
Next

Set Folder = Nothing
Set File = Nothing
End Sub

413191246se · 发表于 2020-8-9 10:16

本帖最后由 413191246se 于 2020-8-9 21:30 编辑

cuanju 老师辛苦了！代码已保存，容后测试。----最终函数 SelectFolder 参考了 cuanju 老师的代码，精简到 4 行！多谢！
但 cuanju 老师和小花鹿老师所写的 Excel 代码，有的未改成 Word 的，也有改的。
总之，我一看 Excel VBA 就吓够呛，不要来 Excel 的，我只来 Word 的。

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

[分享] 循环遍历文件夹及子文件夹（宏）2020-8-9（定稿）

评分

评分