Word VBA: Изменить шрифт пустых абзацев

[Anton]

Добрый день!
Мучаюсь с подгонкой текста. Решаю такую задачу: можно ли шрифт все пустых абзацев (содержащих только знак абзаца) уменьшить на заданное значение, например, был везде шрифт размером 12, а у пустых абзацев он будет 8.

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

Всем макросы, которые ниже, не уменьшают пустые абзацы в таблице.

Поиск во всём файле. Обрабатывается только основной текст (сноски и т.д. не обрабатываются).
Не уменьшаются пустые абзацы, которые в одном экземпляре, такое может быть, если пустой абзац находится после таблицы.

Макрос

Sub Макрос()

    Dim find_rng As Range, find As find
   
   
    '1. Созднаие объектов, которые будут искать.
    Set find_rng = ActiveDocument.Range(0, 0)
    Set find = find_rng.find
   
    '2. Отключение монитора.
    Application.ScreenUpdating = False
   
    '3. Настройка поиска.
    find.text = "^13{2;}"
    find.MatchWildcards = True
    find.Wrap = wdFindStop
   
    '4. Изменение шрифта.
    Do While find.Execute = True
   
        ' Если абзац в таблице, то установка невидимого курсора за таблицей.
        If find_rng.Information(wdWithInTable) = True Then
            find_rng.SetRange Start:=find_rng.Tables(1).Range.End, End:=find_rng.Tables(1).Range.End
        ' Если абзац не в таблице.
        Else
            ' Убирание из найденного фрагмента первого абзаца, если первый абзац непустой.
            If find_rng.Paragraphs(1).Range.Characters.Count <> 1 Then
                find_rng.MoveStart Unit:=wdParagraph, Count:=1
            End If
            ' Изменение шрифта.
            find_rng.Font.Size = 8
            ' Превращение рейнджа в точку вставки и установка точки вставки справа от найденного фрагмента.
            find_rng.Collapse Direction:=wdCollapseEnd
        End If
    Loop
   
    '5. Включение монитора.
    Application.ScreenUpdating = True
   
    '6. Сообщение.
    MsgBox "Готово.", vbInformation
   
End Sub

[свернуть]

Поиск в выделенном фрагменте. Работает во всех частях файла: в основном тексте, сносках и т.д.
Не уменьшаются пустые абзацы, которые в одном экземпляре, такое может быть, если пустой абзац находится после таблицы.
Не уменьшаются абзацы, которые находятся в конце выделения, если после выделения сразу есть ещё пустые абзацы.

Макрос

Sub Макрос()

    Dim rng_find As Range, fnd As Find, FirstEntry As Boolean, SelStart As Long, SelEnd As Long
   
   
    '1. Отключение монитора.
    Application.ScreenUpdating = False
   
    '2. Запоминание начала и конца выделения.
    SelStart = Selection.Start
    SelEnd = Selection.End
   
    '3. Создание объектов, которые будут искать.
    Set rng_find = Selection.Range.Duplicate
    rng_find.Collapse Direction:=wdCollapseStart
    Set fnd = rng_find.Find
   
    '4. Настройка поиска.
    fnd.text = "^13{2;}"
    fnd.MatchWildcards = True
    ' wdFindContinue - иначе поиск останавливался раньше, например, когда в начале был абзац, а затем таблица.
    fnd.Wrap = wdFindContinue
    FirstEntry = True
   
    '5. Поиск.
    Do While fnd.Execute = True
       
        ' Если это первое вхождение.
        If FirstEntry = True Then
            FirstEntry = False
            ' Если найдено за пределами выделенного фрагмента.
            If (rng_find.Start < SelStart) Or (rng_find.End > SelEnd) Then
                Exit Do
            End If
        ' Если это последующие вхождения.
        Else
            If (rng_find.Start <= SelStart) Or (rng_find.End > SelEnd) Then
                Exit Do
            End If
        End If
       
        ' Если абзац в таблице, то установка невидимого курсора за таблицей.
        If rng_find.Information(wdWithInTable) = True Then
            rng_find.SetRange Start:=rng_find.Tables(1).Range.End, End:=rng_find.Tables(1).Range.End
        ' Если абзац не в таблице.
        Else
            ' Убирание из найденного фрагмента первого абзаца, если первый абзац непустой.
            If rng_find.Paragraphs(1).Range.Characters.Count <> 1 Then
                rng_find.MoveStart Unit:=wdParagraph, Count:=1
            End If
            ' Изменение шрифта.
            rng_find.Font.Size = 8
        End If
   
    Loop
   
    '6. Включение монитора.
    Application.ScreenUpdating = True
   
    '7. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

[свернуть]

Поиск в выделенном фрагменте. Работает во всех частях файла: в основном тексте, сносках и т.д.
Этот макрос уменьшает одиночные абзацы и абзацы, которые находятся в конце выделения, если после выделения сразу есть ещё пустые абзацы.

Макрос

Sub Макрос()

    Dim par As Paragraph
   
   
    '1. Отключение монитора.
    Application.ScreenUpdating = False
   
    '2. Изменение размера шрифта у пустых абзацев.
    For Each par In Selection.Paragraphs
        If par.Range.Information(wdWithInTable) = False Then
            If par.Range.Characters.Count = 1 Then
                par.Range.Font.Size = 8
            End If
        End If
    Next par
   
    '3. Включение монитора.
    Application.ScreenUpdating = True
   
    '4. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

[свернуть]

Отличие двух последних макросов в скорости работы. Метод "Find" быстрее работает, чем цикл по всем абзацам.

[Anton]

Третий метод, хоть и немного медленнее, но работает как надо!
Большое спасибо!