如何批量将目录及子目录下Word文档关联模板改为Normal.dotm

需要批量移除大量嵌套目录下Word文档的模板链接，将关联模板改为Normal.dotm。当前仅能处理单个文档或单一目录，无法遍历子目录，手动处理300+目录完全不现实。

尝试过的方案及问题 #

1. Graham Mayor批量处理工具 #

工具运行无报错，显示文件已修改，但实际文档的关联模板并未改为Normal.dotm。使用的函数代码如下：

Function TemplateReplace(oDoc As Document) As Boolean
 On Error GoTo Err_Handler
    With ActiveDocument
        .UpdateStylesOnOpen = False
        .AttachedTemplate = _
            """
    End With
lbl_Exit:
  Exit Function
Err_Handler:
  TemplateReplace = False
  Resume lbl_Exit
End Function

这段代码无报错但未生效。

2. 单目录VBA代码 #

现有一段可成功修改单一目录下所有文档模板的VBA代码，但无法遍历子目录。代码如下：

Sub RunMacroMultipleFiles()

Dim File

Dim path As String

' Path to your folder. Make sure to include the terminating "\"
path = "MYPATH"

' Target file extension
File = Dir(path & "*.docx")

Do While File <> """

Documents.Open FileName:=path & File

Call TemplateRemoval

File = Dir()

Loop

End Sub

Sub TemplateRemoval()
    With ActiveDocument
        .UpdateStylesOnOpen = False
        .AttachedTemplate = _
            """
        .Close _
            SaveChanges:=wdSaveChanges, _
            OriginalFormat:=wdOriginalDocumentFormat
    End With
End Sub

解决方案：支持遍历子目录的VBA代码 #

修改原有代码，添加递归遍历子目录的逻辑，同时修复模板路径的错误（原代码中模板路径为空）：

Sub BatchUpdateTemplatesInSubfolders()
    Dim rootPath As String
    ' 设置根目录，记得末尾加反斜杠
    rootPath = "C:\Your\Root\Folder\"
    
    ' 开始递归遍历所有目录
    ProcessFolder rootPath
End Sub

Sub ProcessFolder(folderPath As String)
    Dim fileName As String
    Dim subFolder As Object
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 处理当前目录下的docx文件
    fileName = Dir(folderPath & "*.docx")
    Do While fileName <> ""
        UpdateDocumentTemplate folderPath & fileName
        fileName = Dir()
    Loop
    
    ' 递归处理子目录
    For Each subFolder In fso.GetFolder(folderPath).SubFolders
        ProcessFolder subFolder.Path & "\"
    Next subFolder
    
    Set fso = Nothing
End Sub

Sub UpdateDocumentTemplate(docPath As String)
    Dim doc As Document
    
    ' 捕获文档打开失败的错误
    On Error Resume Next
    Set doc = Documents.Open(docPath, ReadOnly:=False)
    If Err.Number <> 0 Then
        Debug.Print "无法打开文档: " & docPath
        Err.Clear
        Exit Sub
    End If
    On Error GoTo 0
    
    With doc
        .UpdateStylesOnOpen = False
        ' 自动获取系统默认Normal.dotm路径，避免硬编码错误
        .AttachedTemplate = NormalTemplate.FullName
        .Save
        .Close SaveChanges:=wdDoNotSaveChanges ' 已保存，无需重复操作
    End With
    
    Set doc = Nothing
End Sub

代码说明 #

• 递归遍历：通过ProcessFolder函数自动遍历所有子目录，无需手动逐个指定
• 模板路径修复：用NormalTemplate.FullName自动定位系统默认模板，避免路径错误
• 错误处理：添加文档打开失败的捕获逻辑，单个文档问题不会中断整个批量操作
• 效率优化：修改后直接保存文档，关闭时不再重复保存，提升处理速度

内容的提问来源于stack exchange，提问作者Denver Crittendon