使用VBA（包括文本框）突出显示Microsoft word文档中的word实例

以下代码查找特定单词并在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

---

找到代码

对于文档范围的查找/替换，可以使用以下代码：

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

这样的代码将处理文档的正文、页眉、页脚、文本框、脚注、尾注等。表面上看，人们希望能够在文档的故事范围内循环。但是，StoryRanges对象不能可靠地与页眉、页脚和形状的查找/替换一起工作-在具有多个页眉、页脚和形状成员的StoryRange上查找/替换似乎只查看第一个成员

对于选择，您可以使用以下内容：

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

---

Word文档由多个故事范围组成。ActiveDocument.COntent实际上是ActiveDocument.StoryRanges（wdMainTextStory）。因此，您可能需要在ActiveDocument.StoryRange（wdTextFrameStory）中搜索每个帧中的范围