如何使此代码递归应用于所有子文件夹

Question

我发现这段代码可以将 .doc 文件更改为 .docx 文件。我想修改它，以便我可以指定一个顶级文件夹并让它通过它和每个子文件夹工作。感谢任何帮助。

Sub TranslateDocIntoDocx()
  Dim objWordApplication As New Word.Application
  Dim objWordDocument As Word.Document
  Dim strFile As String
  Dim strFolder As String

  strFolder = "C:\Temp\doc\"
  strFile = Dir(strFolder & "*.doc", vbNormal)

  While strFile <> ""
    With objWordApplication
      Set objWordDocument = .Documents.Open(FileName:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)

      With objWordDocument
        .SaveAs FileName:=strFolder & Replace(strFile, "doc", "docx"), FileFormat:=16
        .Close
      End With
    End With
    strFile = Dir()
  Wend

  Set objWordDocument = Nothing
  Set objWordApplication = Nothing
End Sub

Answer 1

我建议从 Dir 切换到 FileSystemObject。使用 FSO，您可以使用 GetFolder 获取作为对象的文件夹，然后作为集合访问 Folder 对象的文件和文件夹。这会启用 For Each 循环，例如 For Each File In Folder。然后您可以执行递归 For Each SubFolder In Folder，您可以在其中重新调用宏，就好像每个子文件夹都是顶级文件夹一样。

Sub TranslateDocIntoDocx()
    Dim objWordApplication As New Word.Application

    Dim strFolder As String
    strFolder = "C:\Temp\doc\"
    
    Dim StartingFolder As Object
    Set StartingFolder = CreateObject("Scripting.FileSystemObject").GetFolder(strFolder)
    
    
    FolderToDocx StartingFolder, objWordApplication
    
    Set objWordApplication = Nothing
End Sub
Sub FolderToDocx(Folder As Object, wdApp As Word.Application)
    Dim File As Object
    For Each File In Folder.Files
        If LCase(Split(File.Name, ".")(1)) = "doc" Then SaveToDocx File, wdApp
    Next
    
    Dim SubFolder As Object
    For Each SubFolder In Folder.Subfolders
        FolderToDocx SubFolder, wdApp
    Next
End Sub

Sub SaveToDocx(File As Object, wdApp As Word.Application)
    With wdApp.Documents.Open(File.Path, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
        .SaveAs Filename:=File.Path & "x"), FileFormat:=16
        .Close
    End With
End Sub

我在这个答案中做的文件匹配表达式只是一个例子。您可能希望改进该表达式以防止错误。可能出现的一个错误是 Microsoft Office 临时文件。它们通常是隐藏的，并以 ~$ 为前缀，例如 ~$Word Document.docx。因此，为避免意外匹配其中一个，最好排除任何带有该前缀的内容。

Answer 2

我建议将文件搜索拆分成一个单独的函数：这样可以更轻松地调整您的逻辑，并且 main 方法不会因查找文件的代码而过载。

Sub TranslateDocIntoDocx()
    Dim objWordApplication As New Word.Application
    Dim objWordDocument As Word.Document
    Dim colFiles As Collection
    Dim strFile
  
    Set colFiles = GetMatchingFiles("C:\Temp\doc\", "*.doc")
    For Each strFile In colFiles
        With objWordApplication
            Set objWordDocument = .Documents.Open(Filename:=strFile, _
                     AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
    
            With objWordDocument
                .SaveAs Filename:=strFile & "x", FileFormat:=16
                .Close
            End With
        End With
    Next strFile
End Sub


'Search beginning at supplied folder root, including subfolders, for
'   files matching the supplied pattern.  Return all matches in a Collection
Function GetMatchingFiles(startPath As String, filePattern As String) As Collection 'of paths
    Dim colFolders As New Collection, colFiles As New Collection
    Dim fso As Object, fldr, subfldr, fl
    
    Set fso = CreateObject("scripting.filesystemobject")
    colFolders.Add startPath         'queue up root folder for processing
    
    Do While colFolders.Count > 0 'loop until the queue is empty
        fldr = colFolders(1)      'get next folder from queue
        colFolders.Remove 1       'remove current folder from queue
        With fso.getfolder(fldr)
            For Each fl In .Files
                If UCase(fl.Name) Like UCase(filePattern) Then  'check pattern
                    colFiles.Add fl.Path     'collect the full path
                End If
            Next fl
            For Each subfldr In .subFolders
                colFolders.Add subfldr.Path 'queue any subfolders
            Next subfldr
        End With
    Loop
    Set GetMatchingFiles = colFiles
End Function

如何使此代码递归应用于所有子文件夹

How to make this code apply recursively to all sub-folders

vba

ms-word