VBA Word，删除特定的突出显示颜色 "Red" 有时卡在无限循环中

Question

我想从 MS Word 文档中删除红色突出显示颜色。

说明：我在 MS Word 文档中制作了一个模块，该模块 search/find 任何用红色突出显示的文本 - 下图中显示的工具中用红色标记的文本。以下代码要么工作正常，要么使 MS Word 停止响应。我不确定它为什么会崩溃，但我猜是由于我正在使用的循环。我希望有这样的东西： .Replacement.HighlightColorIndex = wdred ;然后 .Execute Replace:=wdReplaceAll ;而不是循环。

我写的VBA代码：

Sub RemoveSpecificHighlightingColor()
'
' Remove Specific Highlighting Color Macro
' This Macro go through the document and search for any Red color highlighting word and remove it
' colors code: https://docs.microsoft.com/en-us/office/vba/api/word.wdcolorindex
'
    Selection.GoTo wdGoToPage, wdGoToAbsolute, 1 'Start at the top of the document
    Selection.Find.ClearFormatting
    Selection.Find.Highlight = True
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop 'stop at the end of the document
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        Do While (.Execute(Forward:=True) = True) = True
            DoEvents 'keeps Word responsive
            If Selection.Range.HighlightColorIndex = wdRed Then
               Selection.Range.Delete
            End If
        Loop
        MsgBox "Done!" ' just for testing
    End With
End Sub

关于代码的一些解释：

我注意到如果我 select 在文档的中间然后运行代码，代码从鼠标 selection 开始而不是从顶部开始。这就是我提到第一个声明的原因。
我从记录宏功能和在线帮助中获得的一些代码。记录宏检测所有突出显示颜色而不是特定颜色。
我使用了 Selection.Find 所以我 selected .Wrap = wdFindStop
保留或删除 Format、MatchCase、MatchWholeWord、MatchWildcards、MatchSoundsLike 和 MatchAllWordForms 都没有区别。
主要问题是 While 循环或我正在使用的任何循环。代码中显示的检查所有突出显示颜色，如果颜色为红色，则将其删除，否则检查另一种颜色。

感谢任何帮助，谢谢！

Answer 1

您的代码的最大问题是您正在使用 Selection 对象。当您在代码中添加 select 内容时，每次更改 selection 都必须重新绘制屏幕。由于 Selection.Find selects 它发现每次匹配都需要重绘。

在这种情况下，您可以通过使用 Range 对象来避免使用 Selection（ActiveDocument.Content 是一个范围）。当您将 .Find 与范围一起使用时，每次找到匹配项时都会重新定义范围，使您能够更改该范围的属性。

Sub RemoveSpecificHighlightingColor()
   Application.ScreenUpdating = False
   With ActiveDocument.Content
      With .Find
         .ClearFormatting
         .Replacement.ClearFormatting
         .Highlight = True
         .Text = ""
         .Replacement.Text = ""
         .Forward = True
         .Wrap = wdFindStop 'stop at the end of the document
         .Format = True
         .MatchCase = False
         .MatchWholeWord = False
         .MatchWildcards = False
         .MatchSoundsLike = False
         .MatchAllWordForms = False
      End With
      Do While .Find.Execute = True
         If .HighlightColorIndex = wdRed Then .Delete
      Loop
   End With
   Application.ScreenUpdating = True
End Sub

Answer 2

例如：

Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Format = True
    .Forward = True
    .Highlight = True
    .Wrap = wdFindStop
  End With
  Do While .Find.Execute
    If .HighlightColorIndex = wdRed Then .Delete
    'The next If ... End If block is needed if the highlighted content could be in a table
    If .Information(wdWithInTable) = True Then
      If .End = .Cells(1).Range.End - 1 Then
        .End = .Cells(1).Range.End
        .Collapse wdCollapseEnd
        If .Information(wdAtEndOfRowMarker) = True Then
          .End = .End + 1
        End If
      End If
    End If
    'The next line is  needed if the highlighted content could include the final paragraph break
    If .End = ActiveDocument.Range.End Then Exit Do
    .Collapse wdCollapseEnd
  Loop
End With
Application.ScreenUpdating = True
End Sub

请注意，Word 的查找中存在一个错误，这意味着如果文档包含一个突出显示的段落，它将找不到任何内容。此外，我没有包含代码来测试找到的范围是否跨越某些文本以及字段的一部分或跨越两种或多种突出显示颜色。因此，这两种情况都不会被处理。

Answer 3

我试图追踪这个问题。我注意到的是，仅在某些文档中（.doc 和 .docx 文件类型的混合），一旦我运行代码，它就会遍历文档页面并找到并删除红色突出显示颜色，一旦所有这些都是取而代之的是，MS Word 卡住了。 MS Word一旦卡住，光标快速变化，好像要重绘屏幕，几秒后程序停止响应，即使我等一会儿也会卡住，直到我强行关闭女士字。无论文档中是否使用红色突出显示颜色，都会发生这种情况。

代码解释：

代码运行通过使代码从第一页开始并计算页数来单独显示每一页。然后浏览每一页和 select 文本。
仅针对特定 selection 应用过滤代码并删除，然后检查新页面。
我把pause/stuck当作一个没有上拉或下拉电阻的弹跳按钮，也就是说，一旦按下物理按钮，它就会在达到稳定状态之前波动。
迭代...

我使用的最终代码，它现在适用于所有文档，如下所示：

Sub RemoveSpecificHighlightingColor()
'
' Remove Specific Highlighting Color Macro
' This Macro go through the document and search for any Red color highlighting word and remove it
' colors code: https://docs.microsoft.com/en-us/office/vba/api/word.wdcolorindex
'
    Dim NumberOfAllPages As Integer
    ' Dim LastPageNumber As Integer
    Dim PageNumber As Integer
    Dim TempCounter As Integer
    Dim TemoEnd As Long
    
    Selection.Find.ClearFormatting
    PageNumber = 1 'Starting page
    NumberOfAllPages = ActiveDocument.ActiveWindow.Panes(1).Pages.Count
   ' LastPageNumber = 3 'Last page to reach - for testing
    Selection.GoTo wdGoToPage, wdGoToAbsolute, PageNumber 'GoTo Page PageNumber
    
   ' Debug.Print "Start"
    While PageNumber - 1 < NumberOfAllPages 'LastPageNumber
        DoEvents 'keeps document responsive
        Selection.GoTo wdGoToPage, wdGoToAbsolute, PageNumber 'GoTo Page PageNumber
        Selection.Bookmarks("\Page").Select 'Select all the text in the page
        
        With Selection.Find
            .Highlight = True
            .Text = ""
            .Replacement.Text = ""
            .Forward = True
            Do While (.Execute(Forward:=True) = True) = True
                DoEvents 'keeps document responsive

                If Selection.Range.HighlightColorIndex = wdRed Then Selection.Range.Delete
                
                ' If the process is stuck at the same location for while then (50 times) it mean the page is full check from Red Highlighting Color
                If ActiveWindow.Selection.End = TemoEnd Then
                    TempCounter = TempCounter + 1
                End If
                If TempCounter > 50 Then Exit Do
                
              '  Debug.Print ActiveDocument.Range.End
              '  Debug.Print ActiveWindow.Selection.End
                
                TemoEnd = ActiveWindow.Selection.End
            Loop
        End With
        TempCounter = 0 ' reset counter
       ' Debug.Print PageNumber
        PageNumber = PageNumber + 1
    Wend
End Sub

Answer 4

我不能告诉你错误在哪里，但这是一个有效的代码

Sub UNHIGHCOLOR()
'HOW MANY HIGHLIGHT REGIONS ARE - store to AAAM
Selection.HomeKey wdStory
'HIG_COUNT Macro
'CTRL-FN-SHIFT TO BREAK
START:
'Selection.HomeKey wdStory
Selection.Find.ClearFormatting
Selection.Find.Highlight = True
With Selection.Find
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
If .Found Then
'MsgBox "found"
If Selection.Range.HighlightColorIndex = wdRed Then
'MsgBox "RED"
'Selection.Range.HighlightColorIndex = 0
End If
AAAM = AAAM + 1
GoTo START
Else
'MsgBox "not found"
'MsgBox AAAM & " HIGH REGIONS"
End If
End With
Selection.HomeKey wdStory
'*********************************************************
'FOR AAAM REGIONS CHANGE HIGHLIGHT RED COLORS TO NO COLOR
For X = 1 To AAAM + 1
'UNHIGHCOLOR_RED_NEXT
Selection.Find.ClearFormatting
Selection.Find.Highlight = True
With Selection.Find
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
    End With
    If Selection.Range.HighlightColorIndex = wdRed Then
    'MsgBox "RED"
    Selection.Range.HighlightColorIndex = 0 'NO COLOR
    End If
    Selection.Collapse (wdCollapseEnd) 'TO FIND NEXT
    Next
End Sub

VBA Word，删除特定的突出显示颜色 "Red" 有时卡在无限循环中

VBA Word, Remove Specific Highlighting Color "Red" get stuck some times at infinite loop

vba

ms-word