CODEWITHSUNDEEP
vbams-word
JJc
JJc

Reputation: 13

Finding and redacting text highlighted with specific color

I have the VBA code below which looks for highlighted and underlined text in a Word document and redacts it (i.e. replaces it with "x"s and highlights in black).

I would like to identify and redact only text highlighted in turquoise (or a specific colour of choice) leaving the text highlighted in other colours intact.

I tried altering the code in many ways but nothing works.

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

Upvotes: 1

Views: 915

Answers (1)

Cindy Meister
Cindy Meister

Reputation: 25673

What's needed in order to identify the Highlight color is the property Range.HighlightColorIndex.

I've streamlined the code below somewhat.

  1. Made sure the search starts at the beginning of the document (this can be removed/commented out if not needed, but not having it was causing some problems during testing): Selection.HomeKey wdStory

  2. Set .Wrap to 'wdFindStop` as it's usual to run a search from start to end. Again, this can be changed back if you expressly want to be prompted to start again at the beginning of the document.

  3. Changed how flag is being used in order to test whether Find.Execute was successful. This method returns true if successful, otherwise false. Testing whether the selection is underlined would not be reliable since the last successful Find would be underlined and the selection will not move if nothing is found.

  4. If the search is successful and the found underlined text is highlighted turquoise, then the redaction manipulation is performed on it.

Note that I also changed While...Wend, which is deprecated to the newer Do...Loopconstruct. This is much more flexible in how the looping test can be constructed.

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

Upvotes: 0

Related Questions