Word Макрос: Закрасить сжатые и расширенные абзацы

[Anton]

Добрый день еще раз. Замучился с одним текстом, где есть много абзацев со сжатым или расширенным шрифтом (Шрифт - Дополнительно - Интервал - разряженный или уплотненный). А весь сразу текст изменить нельзя, предпочтительно изменять и подгонять абзацы, у которых уже изменен интервал у шрифта.

А можно ли теоретически покрасить такие абзацы цветом, причем чтобы светло-оранжевый был у абзацев с разряженным шрифтом, а светло-голубой - у абзацев со сжатым шрифтом. Слова могут быть в абзаце не сжаты, поджаты или разряжены одновременно, такие не учитывать. Как определять, что в абзаце шрифт сжат - не понимаю. Может быть, по первым буквам или словам?

[Администратор]

В пределах одного абзаца у символов может быть разное сжатие? Например, у одно символа уплотнение 0,1, у другого 0,2? Или внутри одного абзаца у всех символов сжатие одинаковое?

[Anton]

Я посмотрел - у меня почти все (в рабочем документе, например, только один с разным сжатием) либо сжаты либо расширены.

[Администратор]

Вы так и не ответили на вопрос. Я про другое спрашивал. Я про расширение не спрашивал.

[Anton]

Одинаковое.

[Администратор]

В абзаце с расширением тоже у всех символов одинаковое расширение?

[Anton]

Да, тоже одинаковое.

[Администратор]

Макрос

Sub Макрос()

    Dim par As Paragraph, spacing As Single
   
    '1. Отключение монитора (может это ускорит макрос и не будет мерцать).
    Application.ScreenUpdating = False
   
    '2. Цикл по всем абзацам в основной части файла.
    For Each par In ActiveDocument.Paragraphs
        ' Запись интервала в переменную, чтобы ускорить макрос, чтобы
            ' не использовать объекты, а использовать переменную.
        spacing = par.Range.Font.spacing
        ' Если во фрагменте разные интервалы, то возвращается число "9999999".
        If spacing <> 9999999 Then
            ' Если интервал разреженный, то число положительное.
            If spacing > 0 Then
                par.Range.Shading.BackgroundPatternColor = -654246042
            ' Если интервал уплотнённый, то число отрицательное.
            ElseIf spacing < 0 Then
                par.Range.Shading.BackgroundPatternColor = -671023258
            End If
        End If
    Next par
   
    '3. Включение монитора.
    Application.ScreenUpdating = True
   
    '4. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

[свернуть]

[Anton]

Все сработало на ура!

Большое-пребольшое спасибо!