Setting Normal.dotm template on Word Docs for Directory and SubDirectories VBA

Question

I am trying to remove links to templates on a large number of word documents spread a large directory and subdirectories. So far, I have been able to remove templates on individual documents, or an a directory, but not on subdirectories. I have been trying to utilize Graham Mayor's Batch processes utility https://www.gmayor.com/document_batch_processes.htm but to no avail. No errors are reported and all files in a test directory are listed as having been modified but none of them have the normal template instead of the prior specified templates. I am also open to using Powershell for this, but i have not investigated how to do that yet and have a sunken cost in VBA at this point.

Here is my Function used in Graham Mayor's tool:

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

This code returns no errors and claims it completes successfully, but the template still shows as the prior specified template instead of the normal.dotm necessary.

I also have the entirety of my code that I have successfully used to change the template for all documents in a directory, but not subdirectories, in case that is easier to modify. Source for this info: https://www.litigationsupporttipofthenight.com/single-post/2020/07/21/vba-code-to-run-a-macro-on-multiple-word-files

Sub RunMacroMultipleFiles()

Dim File

Dim path As String

' this code taken from Running a macro on all files in a folder - Tips for Module Creation

' Path to your folder. MY folder is listed below. I bet yours is different.

' make SURE you include the terminating "\"

'YOU MUST EDIT THIS.

path = "MYPATH"

'Change this file extension to the file you are opening. .htm is listed below. You may have rtf or docx.

'YOU MUST EDIT THIS.

File = Dir(path & "*.docx")

Do While File <> ""

Documents.Open FileName:=path & File

' This is the call to the macro you want to run on each file the folder

'YOU MUST EDIT THIS. You put your Macro name here.

Call TemplateRemoval

' set file to next in Dir

File = Dir()

Loop

End Sub

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

This second code block would work if it could filter through subdirectories, but I have over 300 directories to go through and that isn't feasible.

Answer 1

Something like this should work:

Sub RunMacroMultipleFiles()

    Const ROOT_PATH As String = "C:\Temp\" 'for example
    
    Dim docFiles As Collection, f As Object, doc As Document
    
    Set docFiles = GetFileMatches(ROOT_PATH, "*.docx") 
    
    For Each f In docFiles
        Set doc = Documents.Open(f.path)
        TemplateRemoval doc 'pass document to `TemplateRemoval`
    Next f
End Sub

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

'Return a collection of file objects given a starting folder and a file pattern
'  e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetFileMatches(startFolder As String, filePattern As String, _
                    Optional subFolders As Boolean = True) As Collection

    Dim fso, fldr, f, subFldr
    Dim colFiles As New Collection  'for files to be returned
    Dim colSub As New Collection    'for queueing subfolders

    Set fso = CreateObject("scripting.filesystemobject")
    colSub.Add startFolder  'start point for searching

    Do While colSub.Count > 0 'while have any folders to check...

        Set fldr = fso.getfolder(colSub(1)) 'get the next folder
        colSub.Remove 1                     '...and remove from the queue 

        For Each f In fldr.Files 'check files in this folder
            If UCase(f.Name) Like UCase(filePattern) Then colFiles.Add f
        Next f

        If subFolders Then 'any subfolders to add to the queue?
            For Each subFldr In fldr.subFolders
                colSub.Add subFldr.path
            Next subFldr
        End If
    Loop
    Set GetFileMatches = colFiles
End Function