Option Explicit
Dim FSO As Object 'a FileSystemObject
Dim oFolder As Object 'the folder object
Dim oSubFolder As Object 'the subfolders collection
Dim oFiles As Object 'the files object
Dim i As Long, j As Long
Sub Main()
' Minimise screen flickering
Application.ScreenUpdating = False
Dim StrFolder As String
' Browse for the starting folder
StrFolder = GetTopFolder
If StrFolder = "" Then Exit Sub
i = 0: j = 0
' Search the top-level folder
Call GetFolder(StrFolder & "\")
' Search the subfolders for more files
Call SearchSubFolders(StrFolder)
' Return control of status bar to Word
Application.StatusBar = ""
' Restore screen updating
Application.ScreenUpdating = True
MsgBox i & " of " & j & " files updated.", vbOKOnly
End Sub
Function GetTopFolder() As String
GetTopFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetTopFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
Sub SearchSubFolders(strStartPath As String)
If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(strStartPath)
Set oSubFolder = oFolder.subfolders
For Each oFolder In oSubFolder
  Set oFiles = oFolder.Files
  ' Search the current folder
  Call GetFolder(oFolder.Path & "\")
  ' Call ourself to see if there are subfolders below
  Call SearchSubFolders(oFolder.Path)
Next
Set FSO = Nothing
End Sub
Sub GetFolder(StrFolder As String)
Dim strFile As String
strFile = Dir(StrFolder & "*.doc")
' Process the files in the folder
While strFile <> ""
  ' Update the status bar is just to let us know where we are
  Application.StatusBar = StrFolder & strFile
  Call UpdateTemplateRefs(StrFolder & strFile)
  strFile = Dir()
Wend
End Sub
Sub UpdateTemplateRefs(strDoc As String)
' This sub updates the template paths for files after a server
' change. Simply insert however much of the lower end of the
' server paths differ as the OldServer and NewServer variables.
Dim OldServer As String, NewServer As String, strPath As String
Dim oItem As Object, StrDtTm As String
OldServer = "\\TSB\VOL1": NewServer = "\\TSLSERVER\Files"
' Store the file's current Date/Time stamp.
If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
Set oItem = FSO.GetFile(strDoc)
StrDtTm = oItem.DateLastModified
' Open the document
Documents.Open strDoc, AddToRecentFiles:=False, ReadOnly:=False, Format:=wdOpenFormatAuto
With ActiveDocument
  If .ProtectionType = wdNoProtection Then
    ' Update the template path
    strPath = Dialogs(wdDialogToolsTemplates).Template
    If LCase(Left(strPath, Len(OldServer))) = LCase(OldServer) Then
      ' Update the file counter for changed files
      i = i + 1
      ' Get the new template path & name
      strPath = NewServer & Mid(strPath, Len(OldServer) + 1)
      ' Check whether the template exists
      If Dir(strPath) <> "" Then
        ' If found, update the path
        .AttachedTemplate = NewServer & Mid(strPath, Len(OldServer) + 1)
      Else
        ' If not found, reset the template to 'Normal'
        .AttachedTemplate = ""
        ' Output an error report in the document from which the macro is run.
        ThisDocument.Range.InsertAfter vbCr & "Template: " & strPath & " not found for " & strDoc
      End If
    End If
  Else
    ' Output a 'protected' file report in the document from which the macro is run.
    ThisDocument.Range.InsertAfter vbCr & strDoc & " protected. Not updated."
  End If
  .Close SaveChanges:=True
End With
' Update the main file counter
j = j + 1
' Let Word do its housekeeping
DoEvents
' Reset the file's Date/Time stamp.
Set oItem = FSO.GetFile(strDoc)
If oItem.DateLastModified <> StrDtTm Then oItem.DateLastModified = StrDtTm
Set oItem = Nothing
End Sub

Sub GetTemplateRef()
With ActiveDocument
  MsgBox Dialogs(wdDialogToolsTemplates).Template
End With
End Sub