Question

我下面有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是识别突出显示颜色的必要条件。

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

确保搜索从文档的开头开始（如果不需要，可以将其删除/注释掉，但在测试过程中不会引起问题）：Selection.HomeKey wdStory
将.Wrap设置为'wdFindStop`，就像通常从头到尾运行搜索一样。同样，如果您明确希望提示您从文档开头重新开始，则可以将其更改回去。
更改了flag的使用方式，以测试Find.Execute是否成功。如果成功，此方法将返回true，否则返回false。测试选择是否带下划线将是不可靠的，因为最后一个成功的Find将带有下划线，并且如果什么也没找到，则选择将不会移动。
如果搜索成功并且找到的带下划线的文本突出显示为青绿色，则对其进行编辑操作。

请注意，我还更改了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

查找和编辑以特定颜色突出显示的文本

1 个答案: