vba - 使用 VBA 突出显示 Microsoft Word 文档中的单词实例，包括文本框

Question

以下代码在 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

代码在这里找到

标签： vbams-word

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

这样的代码将处理文档正文、页眉、页脚、文本框、脚注、尾注等。从表面上看，人们希望能够循环遍历文档的 StoryRanges。但是，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