Поиск и редактирование выделенного текста с определенным цветом в документе - PullRequest
Новая
       71

Поиск и редактирование выделенного текста с определенным цветом в документе

1 голос
/ 09 ноября 2019

Я возился с куском кода VBA для документа Word без особой удачи, и онлайн-ресурсов вокруг этого, похоже, мало. Любая помощь очень ценится.

Итак, у меня есть код 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

1 Ответ

0 голосов
/ 09 ноября 2019

Для определения цвета подсветки необходимо свойство 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
...