时间戳

首页 > 解决方案 > 查找和编辑以特定颜色突出显示的文本

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

标签： vbams-word

解决方案

识别高亮颜色需要的是属性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

推荐阅读