Public Sub
BatchReplaceAnywhere()
'Based
on a macro by Doug Robbins
'with additional input from Peter Hewett
'and Greg Maxey to replace text in all
'the documents in a folder, wherever that text appears.
Dim FirstLoop
As Boolean
Dim myFile
As String
Dim
PathToUse As
String
Dim
myDoc As
Document
Dim
rngstory
As
Word.Range
Dim
pFindTxt As
String
Dim
pReplaceTxt As
String
Dim
lngJunk As Long
Dim
oShp As
Shape
'*******************************************************
' Use this folder
selection for Word versions 2002-7
Dim
fDialog
As
FileDialog
Set
fDialog = Application.FileDialog(msoFileDialogFolderPicker)
' Get the
folder containing the files
With
fDialog
.Title = "Select
Folder containing the documents to be modified and click OK"
.AllowMultiSelect =
False
.InitialView =
msoFileDialogViewList
If
.Show <> -1
Then
MsgBox "Cancelled By User", , "Batch Replace Anywhere"
Exit Sub
End If
PathToUse =
fDialog.SelectedItems.Item(1)
If
Right(PathToUse, 1) <> "\"
Then
PathToUse = PathToUse + "\"
End With
'Close any
documents that may be open
If
Documents.Count > 0
Then
Documents.Close
Savechanges:=wdPromptToSaveChanges
End If
FirstLoop =
True
'*******************************************************
'End of Folder selectiom
'*******************************************************
'Alternative folder selection for older Word
versions
'With Dialogs(wdDialogCopyFile)
' If .Display <> 0 Then
' PathToUse = .Directory
' Else
' MsgBox "Cancelled by User"
' Exit Sub
' End If
'End With
'If Documents.Count > 0 Then
' Documents.Close Savechanges:=wdPromptToSaveChanges
'End If
'
'FirstLoop = True
'
'If Left(PathToUse, 1) = Chr(34) Then
' PathToUse = Mid(PathToUse, 2, Len(PathToUse) - 2)
'End If
'**********************************************************
'End of folder selection version 2
myFile = Dir$(PathToUse & "*.doc")
While
myFile <> ""
'Get the text
to be replaced and the replacement
If
FirstLoop =
True Then
pFindTxt = InputBox("Enter the text that you want to replace.", _
"Batch Replace Anywhere")
If
pFindTxt = ""
Then
MsgBox "Cancelled by
User", , _
"Batch replace Anywhere"
Exit Sub
End If
Tryagain:
pReplaceTxt = InputBox("Enter the replacement text.", _
"Batch ReplaceAnywhere ")
If
pReplaceTxt = ""
Then
If
MsgBox("Do you just
want to delete the found text?", _
vbYesNoCancel, "Batch Replace Anywhere") = vbNo
Then
GoTo Tryagain
ElseIf
vbCancel Then
MsgBox "Cancelled by User.", , "Batch Replace Anywhere"
Exit Sub
End If
End If
End If
FirstLoop =
False
'Open each file and
make the replacement
Set
myDoc = Documents.Open(PathToUse & myFile)
'Fix the
skipped blank Header/Footer problem
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
ResetFRParameters
'Iterate
through all story types in the current document
For Each
rngstory In
ActiveDocument.StoryRanges
'Iterate
through all linked stories
Do
SrcAndRplInStory rngstory, pFindTxt, pReplaceTxt
On Error Resume Next
Select Case
rngstory.StoryType
Case
6, 7, 8, 9, 10, 11
If
rngstory.ShapeRange.Count > 0
Then
For Each
oShp In rngstory.ShapeRange
If
oShp.TextFrame.HasText
Then
SrcAndRplInStory oShp.TextFrame.TextRange, _
pFindTxt, pReplaceTxt
End If
Next
End If
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Get next linked
story (if any)
Set
rngstory = rngstory.NextStoryRange
Loop Until
rngstory Is
Nothing
Next
'Close the
file, saving the changes.
myDoc.Close Savechanges:=wdSaveChanges
myFile = Dir$()
Wend
End Sub
Public Sub
SrcAndRplInStory(ByVal rngstory
As
Word.Range, _
ByVal
strSearch As
String, _
ByVal
strReplace As
String)
With
rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = strSearch
.Replacement.Text =
strReplace
.Execute Replace:=wdReplaceAll
End With
End Sub
Sub
ResetFRParameters()
With
Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text =
""
.Forward = True
.Wrap =
wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord =
False
.MatchWildcards =
False
.MatchSoundsLike =
False
.MatchAllWordForms =
False
.Execute
End With
End Sub
