Выделите экземпляры слова в документе Microsoft Word с помощью VBA, включая текстовые поля

Question

Следующий код находит указанные c слова и выделяет их в документе Microsoft Word. Код работает отлично. Однако, когда код выполняется, он не выделяет слова внутри текстовых полей. Мне нужно выделить слова в обычном абзаце и внутри текстовых полей. Я возился с этим, однако не могу понять. Любые идеи, которые вы могли бы сделать это?

Dim Word As range

Dim WordCollection(3) As String

Dim Words As Variant

'Define list.

'If you add or delete, change value above in Dim statement.

WordCollection(0) = "Hello World 1"

WordCollection(1) = "Hello World 2"

WordCollection(2) = "Hello World 3"

WordCollection(3) = "Hello World 4"

'Set highlight color.

Options.DefaultHighlightColorIndex = wdYellow

'Clear existing formatting and settings in Find feature.

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

'Set highlight to replace setting.

Selection.Find.Replacement.Highlight = True

'Cycle through document and find words in collection.

'Highlight words when found.

For Each Word In ActiveDocument.Words

For Each Words In WordCollection

With Selection.Find

.Text = Words

.Replacement.Text = ""

.Forward = True

.Wrap = wdFindContinue

.Format = True

.MatchCase = False

.MatchWholeWord = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

Selection.Find.Execute Replace:=wdReplaceAll

Next

Next

End Sub

Код был найден здесь

Answer 1

Для поиска / замены всего документа вы можете использовать такой код:

Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, Sctn As Section, Shp As Shape, HdFt As HeaderFooter, h As Long
h = Options.DefaultHighlightColorIndex
Options.DefaultHighlightColorIndex = wdYellow
With ActiveDocument
  For Each Rng In .StoryRanges
    Call FndRep(Rng)
    For Each Shp In Rng.ShapeRange
      With Shp
        If Not .TextFrame Is Nothing Then
          Call FndRep(.TextFrame.TextRange)
        End If
      End With
    Next
  Next
  For Each Sctn In .Sections
    For Each HdFt In Sctn.Headers
      With HdFt
        If .Exists = True Then
          If .LinkToPrevious = False Then
            Call FndRep(HdFt.Range)
            For Each Shp In HdFt.Shapes
              With Shp
                If Not .TextFrame Is Nothing Then
                  Call FndRep(.TextFrame.TextRange)
                End If
              End With
            Next
          End If
        End If
      End With
    Next
    For Each HdFt In Sctn.Footers
      With HdFt
        If .Exists = True Then
          If .LinkToPrevious = False Then
            Call FndRep(HdFt.Range)
            For Each Shp In HdFt.Shapes
              With Shp
                If Not .TextFrame Is Nothing Then
                  Call FndRep(.TextFrame.TextRange)
                End If
              End With
            Next
          End If
        End If
      End With
    Next
  Next
End With
Options.DefaultHighlightColorIndex = h
Application.ScreenUpdating = True
End Sub

Sub FndRep(Rng As Range)
Dim Sctn As Section, h As Long, i As Long, ArrFnd(), ArrRep()
'Insert Find & Replace expressions here. The arrays must have the same # of entries
ArrFnd = Array("OldText 1", "OldText 2", "OldText 3", "OldText 4")
ArrRep = Array("NewText 1", "NewText 2", "NewText 3", "NewText 4")
With Rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Replacement.Highlight = True
  .Forward = True
  .Wrap = wdFindContinue
  .Format = False
  .MatchCase = False
  .MatchWholeWord = False
  For i = 0 To UBound(ArrFnd)
    .Text = ArrFnd(i)
    .Replacement.Text = ArrRep(i)
    .Execute Replace:=wdReplaceAll
  Next
End With
End Sub

Такой код будет обрабатывать тело документа, верхние и нижние колонтитулы, текстовые поля, сноски, сноски и т. Д. c. Внешне можно было бы ожидать, что он сможет пройти через StoryRanges документа. Тем не менее, объект StoryRanges не работает надежно с Find / Replace для верхних и нижних колонтитулов и фигур - Find / Replace для StoryRange с несколькими элементами header, footer и shape только когда-либо смотрит на первый элемент.

Для выбора вы можете использовать что-то вроде:

Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, Shp As Shape, h As Long, i As Long, ArrFnd(), ArrRep()
ArrFnd = Array("Hello World 1", "Hello World 2", "Hello World 3", "Hello World 4")
ArrRep = Array("Goodbye All 1", "Goodbye All 2", "Goodbye All 3", "Goodbye All 4")
h = Options.DefaultHighlightColorIndex
Options.DefaultHighlightColorIndex = wdYellow
Set Rng = Selection.Range
For i = 0 To UBound(ArrFnd)
  Call RngFndRep(Rng, ArrFnd(i), ArrRep(i))
Next
For Each Shp In Rng.ShapeRange
  With Shp
    If Not .TextFrame Is Nothing Then
      For i = 0 To UBound(ArrFnd)
        Call RngFndRep(.TextFrame.TextRange, ArrFnd(i), ArrRep(i))
      Next
    End If
  End With
Next
Options.DefaultHighlightColorIndex = h
Application.ScreenUpdating = True
End Sub

Sub RngFndRep(Rng As Range, StrFnd, StrRep)
With Rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Replacement.Highlight = True
  .Forward = True
  .Wrap = wdFindStop
  .Format = False
  .MatchCase = False
  .MatchWholeWord = False
  .Text = StrFnd
  .Replacement.Text = StrRep
  .Execute Replace:=wdReplaceAll
End With
End Sub