search and replace text boxes (and other story ranges) words document

Case ".doc", ".RTF", ".dot", ".docx", ".txt", ".csv"
 
' Beginning of Word section
 
'MsgBox "this is a Word document!" & strFileName & " suffix is" & strSuffix
 
 
    Set wrd = CreateObject("Word.Application")
      wrd.Documents.Open strFilePath & strFileName
                    'need to specify main form
                    If Me.ActivateTrackChanges = True Then
                    wrd.ActiveDocument.TrackRevisions = True
                    Else
                    wrd.ActiveDocument.TrackRevisions = False
                    End If
      wrd.Options.DefaultHighlightColorIndex = strHighlightColor
      wrd.Selection.Find.Replacement.ClearFormatting
      If Forms![frmReplacementProject]!HighLight = True Then
      wrd.Selection.Find.Replacement.HighLight = True
      End If
          
    'start replacing list of words in glossary subform
    With [sbfrmProjectGlossary].Form.RecordsetClone
    .MoveFirst
    Do While .EOF = False
        
    strSearchText = .TargetLanguageTerm
    If Forms![frmReplacementProject]!ReplaceOptionID = 1 Then
    strReplaceText = .TargetLanguageCorrectedTerm
    Else
    strReplaceText = strSearchText & " " & strBeforeTag & .TargetLanguageCorrectedTerm & strAfterTag
    End If
    
    wrd.Selection.Find.Execute FindText:=strSearchText, _
       ReplaceWith:=strReplaceText, _
        Format:=True, Replace:=2, Wrap:=wdFindContinue, Forward:=True
        
    'Now search all other stories using Ranges
    Call FindReplaceAnywhere
    
        
       .MoveNext
    Loop
    End With
      
      wrd.ActiveDocument.SaveAs IncrementIfExists(strFilePath & strPrefix & strSaveExtension & strSuffix)
      DoEvents
      wrd.ActiveDocument.Close (True)
      DoEvents
      
      wrd.Quit
' end of Word section
 
 
Public Sub FindReplaceAnywhere()
 
  Dim rngStory As Word.Range
  Dim pFindTxt As String
  Dim pReplaceTxt As String
  Dim lngJunk As Long
  Dim oShp As Shape
    
  pFindTxt = strSearchText
  pReplaceTxt = strReplaceText
    
  'Fix the skipped blank Header/Footer problem
  lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
  'Iterate through all story types in the current document
  For Each rngStory In ActiveDocument.StoryRanges
    'Iterate through all linked stories
    Do
      SearchAndReplaceInStory 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
              SearchAndReplaceInStory 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
 
 
End Sub
 
Public Sub SearchAndReplaceInStory(ByVal rngStory As Word.Range, _
ByVal strSearch As String, ByVal strReplace As String)
 
  With rngStory.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = strSearch
    .Replacement.Text = strReplace
    .Wrap = wdFindContinue
    .Execute Replace:=wdReplaceAll
  End With
 
End Sub

Select allOpen in new window