Replace Header Info - Relative Path Issue

[jwagman1]

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.



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

[macropod]

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:

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