Replace Header Info - Relative Path Issue

Hi there!

I am using the following VBA script to replace information in the header of all documents at a specific path. I need help adjusting the script to replace all header info in all documents at the same path as the word file with the VBA script (relative). Basically i have a Word docx with the VBA script and want to be able to copy it to multiple directories and have it edit the files in the directory where it is saved. The script currently works with specific paths only.

I am using the latest MS Word version.

Code:

---

Sub ReplaceEntireHdr()
    Dim wrd As Word.Application
    Set wrd = CreateObject("word.application")
    wrd.Visible = True
    AppActivate wrd.Name
    'Change the directory to YOUR folder's path
    FName = Dir("C:\temp\*.doc")
    Do While (FName <> "")
        With wrd
            'Change the directory to YOUR folder's path
            .Documents.Open ("C:\Temp" & FName)
            If .ActiveWindow.View.SplitSpecial = wdPaneNone Then
                .ActiveWindow.ActivePane.View.Type = wdPrintView
            Else
                .ActiveWindow.View.Type = wdPrintView
            End If
            .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
            .Selection.WholeStory
            .Selection.Paste
            .ActiveDocument.Save
            .ActiveDocument.Close
        End With
        FName = Dir
    Loop
    Set wrd = Nothing
End Sub

---

If these document are past correspondence, there could be adverse legal implications resulting from changing the content this way, as the documents will no longer be an accurate reflection of the documents actually used; doing so will also invalidate all your backups. This is especially important in the corporate environment. That said, try:

Code:

---

Option Explicit
Dim FSO As Object, oFolder As Object, StrFolds As String
Dim wdDocTgt As Document, wdDocSrc As Document
 
Sub Main()
Application.ScreenUpdating = False
Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
TopLevelFolder = GetFolder: StrFolds = vbCr & TopLevelFolder
If TopLevelFolder = "" Then Exit Sub
Set wdDocSrc = ActiveDocument
If FSO Is Nothing Then
  Set FSO = CreateObject("Scripting.FileSystemObject")
End If
'Get the sub-folder structure
Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders
For Each aFolder In TheFolders
  RecurseWriteFolderName (aFolder)
Next
'Process the documents in each folder
For i = 1 To UBound(Split(StrFolds, vbCr))
  Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i)))
Next
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub
 
Sub UpdateDocuments(oFolder As String)
Dim strFolder As String, strFile As String
strFolder = oFolder
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> wdDocSrc.FullName Then
    Set wdDocTgt = Documents.Open(FileName:=strFolder & "\" & strFile, _
    AddToRecentFiles:=False, Visible:=False)
    With wdDocTgt
      .Sections.First.Headers(wdHeaderFooterPrimary).Range.FormattedText = _
        wdDocSrc.Sections.First.Headers(wdHeaderFooterPrimary).Range.FormattedText
      .Close SaveChanges:=True
    End With
  End If
  strFile = Dir()
Wend
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

Sub RecurseWriteFolderName(aFolder)
Dim SubFolders As Variant, SubFolder As Variant
Set SubFolders = FSO.GetFolder(aFolder).SubFolders
StrFolds = StrFolds & vbCr & CStr(aFolder)
On Error Resume Next
For Each SubFolder In SubFolders
  RecurseWriteFolderName (SubFolder)
Next
End Sub

---