查找并编辑文档中具有特定颜色的突出显示的文本

Question

我一直在为运气不好的Word文档修改一段VBA代码，而在线资源似乎很稀缺。任何帮助，不胜感激。

所以我有下面的VBA代码，该代码本质上是在Word文档中查找突出显示和带下划线的文本并对其进行编辑（即，将其替换为“ x”并以黑色突出显示）。

我想修改代码以仅识别和删除以绿松石色（或选择的特定颜色）突出显示的文本，而保留以其他颜色突出显示的文本。

我试图以多种方式更改代码，但似乎无济于事。请帮助！

    Sub Redact()

    ' Redact Macro
    ' Macro to redact underlined text
    ' If redacted, text will be replaced by x's, coloured black and highlighted black

    Dim OldText, OldLastChar, NewLastChar, NewText, ReplaceChar As String
    Dim RedactForm As Integer
    Dim flag As Boolean

    Application.ScreenUpdating = False

    ReplaceChar = "x"

    flag = True

    While flag = True

        ' Find next selection
            Selection.Find.ClearFormatting
            Selection.Find.Font.Underline = wdUnderlineSingle
            Selection.Find.Highlight = True
            Selection.Find.Replacement.ClearFormatting
            With Selection.Find
                .Text = ""
                .Replacement.Text = ""
                .Forward = True
                .Wrap = wdFindAsk
                .Format = True
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
            End With

            Selection.Find.Execute

            If Selection.Font.Underline = False Then
               flag = False
            End If

        ' Create replacement string
        ' If last character is a carriage return (unicode 13), then keep that carriage return
        OldText = Selection.Text
        OldLastChar = Right(OldText, 1)
        NewLastChar = ReplaceChar
        If OldLastChar Like "[?*#]" Then NewLastChar = String(1, 13)
        NewText = String(Len(OldText) - 1, ReplaceChar) & NewLastChar

        ' Replace text, black block
        Selection.Text = NewText
        Selection.Font.ColorIndex = wdBlack
        Selection.Font.Underline = False
        Selection.Range.HighlightColorIndex = wdBlack
    Wend

    Application.ScreenUpdating = True

    End Sub

Answer 1

为了识别突出显示颜色所需的是属性Range.HighlightColorIndex。

我已经简化了下面的代码。

1. 确保搜索从文档的开头开始（如果不需要，可以将其删除/注释，但是在测试过程中不会引起问题）：Selection.HomeKey wdStory

2. 将.Wrap设置为'wdFindStop`，因为通常从头到尾运行搜索。同样，如果您明确希望提示您在文档开头重新开始，则可以将其更改回去。

3. 更改了flag的使用方式，以测试Find.Execute是否成功。如果成功，此方法返回true，否则返回false。测试选择是否带下划线将是不可靠的，因为最后一次成功的Find将带有下划线，并且如果未找到任何内容，则选择将不会移动。

4. 如果搜索成功并且找到的带下划线的文本突出显示为青绿色，则对其执行编辑操作。

请注意，我还更改了While...Wend，已不推荐使用较新的Do...Loop构造。这样可以更灵活地构建循环测试。

Sub Redact()

    ' Redact Macro
    ' Macro to redact underlined text
    ' If redacted, text will be replaced by x's, coloured black and highlighted black

    Dim OldText, OldLastChar, NewLastChar, NewText, ReplaceChar As String
    Dim RedactForm As Integer
    Dim flag As Boolean

    Application.ScreenUpdating = False

    ReplaceChar = "x"

    'Make sure to start at the beginning of the document
    Selection.HomeKey wdStory
    Do

        ' Find next underline with highlight
        Selection.Find.ClearFormatting
        Selection.Find.Font.Underline = wdUnderlineSingle
        Selection.Find.Highlight = True
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = ""
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With

        flag = Selection.Find.Execute

        If flag Then
            If Selection.Range.HighlightColorIndex = wdTurquoise Then
                ' Create replacement string
                ' If last character is a carriage return (unicode 13), then keep that carriage return
                OldText = Selection.Text
                OldLastChar = Right(OldText, 1)
                NewLastChar = ReplaceChar
                If OldLastChar Like "[?*#]" Then NewLastChar = String(1, 13)
                NewText = String(Len(OldText) - 1, ReplaceChar) & NewLastChar

                ' Replace text, black block
                Selection.Text = NewText
                Selection.Font.ColorIndex = wdBlack
                Selection.Font.Underline = False
                Selection.Range.HighlightColorIndex = wdBlack
                Selection.Collapse wdCollapseEnd
            End If
        End If

    Loop While flag

    Application.ScreenUpdating = True

End Sub