Word Макрос: Запретить перенос заданного количества букв

Автор Anton, 03 марта 2017, 13:19

Anton

Добрый день!
А возможно ли написать макрос, который запрещает перенос в слове, если у слова на следующую строку переносится 2 буквы (например, в слове "компетенцией", может перенестись -ей).

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

У вас в ворд-файле какие переносы сейчас: автоматические или ручные? Под ручными я понимаю не просто что юзер печатает дефисы внутри слова, а которые вставляются вордом.

Anton

Разметка страницы - Расстановка переносов - Авто. У меня всегда так.

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

Если в самом ворде нет такой настройки, то и как правило и в макросе нет такой настройки.
Чтобы в вашем случае контролировать переносы, надо отключить в абзаце автопереносы и затем вам надо вручную расставить переносы так, как вам надо.
Ручные переносы макрос расставляет тоже с помощью диалога.


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

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

Макрос работает в основной части файла и во всех видах сносок. Таблицы не обрабатываются.
Макрос работает только с автоматическими переносами; такие переносы видны на мониторе (в виде дефиса), но фактически дефисов нет.

Макрос. Версия от 05.03.2017 0:37

Sub Макрос1()
   
    Dim text As String, found As Boolean
   
   
    '1. Установка текстового курсора в начало файла.
    Selection.HomeKey Unit:=wdStory
   
    '2. Цикл по строкам.
    Do
        ' Если курсор в таблице, то выход из таблицы.
        If Selection.Information(wdWithInTable) = True Then
            Selection.Tables(1).Range.Characters.Last.Next.Select
        End If
        ' Выделение строки и копирование её текста в переменную.
        Selection.Expand Unit:=wdLine
        text = LCase(Selection.text)
        ' Если справа буква, значит есть автоперенос текста.
        If Right(text, 1) Like "[а-яё]" Then
            ' Переход в нижнюю строку и копирование её текста в переменную.
            Selection.MoveDown Unit:=wdLine, Count:=1
            Selection.Expand Unit:=wdLine
            text = LCase(Selection.text)
            ' Если в начале есть две русские буквы, а затем не русская буква.
            If text Like "[а-яё][а-яё][!а-яё]*" Then
                ' Закраска.
                Selection.Range.HighlightColorIndex = wdYellow
                ' Пометка.
                found = True
            End If
        Else
            ' Без этого бесконечный цикл на последней строке.
            Selection.EndKey
            ' Переход на следующую строку.
            If Selection.MoveDown(Unit:=wdLine, Count:=1) = 0 Then
                Exit Do
            End If
        End If
    Loop

   
    '3. Сообщение.
    If found = True Then
        MsgBox "Найдено.", vbExclamation
    Else
        MsgBox "Не найдено.", vbInformation
    End If
   
End Sub
[свернуть]

Anton

Большое спасибо! Оригинальное решение. Протестирую.

Anton

Протестировал. Почему-то выделяются не все строки.
Пример приложил.

[вложение удалено администратором]

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

Тут даже дело не в макросе, а сам ворд ведёт себя неадекватно.
Выделите первую строку в файле, который вы прикрепили, и нажмите клавишу-стрелку-вниз (это делает макрос). Курсор перейдёт в строку 3, а должен перейти в строку 2. То есть брак в программе "Word".
Предполагаю, что нужно делать отдельно макрос для основного текста и отдельно для сносок.
Вам нужно отслеживать переносы в сносках?

Anton

Сноски тоже нужно обрабатывать. У меня иногда они по половине страницы занимают. И такой макрос здорово выручал бы.

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

Макрос. Версия от 06.03.2017 14:01
Sub Макрос()
   
    Dim founds(1 To 3) As String, var
   
   
    '1. Заполнение массива "founds" исходными данными.
    founds(1) = "нет"
    founds(2) = "нет"
    founds(3) = "нет"
   
    '2. Поиск в основном тексте.
    Call FindTransports(founds(1))
   
    '3. Поиск в страничных сносках.
    If ActiveDocument.Footnotes.Count > 0 Then
        '1) Отображение снизу области со всеми страничными сносками.
            ' При этом курсор переходит в эту область.
        ' Запоминаем, сколько отображается областей, чтобы понять, открылась область со сносками
            ' или закрылась, т.к. команда ниже делает и то и другое в зависимости от ситуации.
        var = ActiveWindow.Panes.Count
        ' Отображение области со сносками.
        ActiveWindow.View.SplitSpecial = wdPaneFootnotes
        ' Проверяем, закрылась область или открылась. Если закрылась, то ещё раз открываем.
        If ActiveWindow.Panes.Count < var Then
            ' Отображение области со сносками.
            ActiveWindow.View.SplitSpecial = wdPaneFootnotes
        End If
        '2) Поиск.
        Call FindTransports(founds(2))
        '3) Закрытие области со сносками.
        ActiveWindow.ActivePane.Close
    End If
   
    '4. Поиск в концевых сносках.
    If ActiveDocument.Endnotes.Count > 0 Then
        '1) Отображение снизу области со всеми концевыми сносками.
        var = ActiveWindow.Panes.Count
        ActiveWindow.View.SplitSpecial = wdPaneEndnotes
        If ActiveWindow.Panes.Count < var Then
            ActiveWindow.View.SplitSpecial = wdPaneEndnotes
        End If
        '2) Поиск.
        Call FindTransports(founds(3))
        '3) Закрытие области со сносками.
        ActiveWindow.ActivePane.Close
    End If

    '5. Сообщение.
    MsgBox _
        "1) основной текст: " & founds(1) & vbCr & _
        "2) страничные сноски: " & founds(2) & vbCr & _
        "3) концевые сноски: " & founds(3), vbInformation

End Sub

Sub FindTransports(found As String)
   
    ' Selection.MoveDown не используется, т.к. происходил перескок через строку.
        ' Это даже было в самом ворде.
    ' Selection.GoTo не используется, т.к. курсор выходит из области сносок.
   
    Dim text As String, lngEnd As Long
   
   
    '1. Установка текстового курсора в начало области (RangeStory).
    Selection.HomeKey Unit:=wdStory
   
    '2. Запись конца области в переменную.
    lngEnd = ActiveDocument.StoryRanges(Selection.StoryType).End - 1
   
    '3. Цикл по строкам.
    Do
   
        ' Если курсор в таблице, то выход из таблицы.
        If Selection.Information(wdWithInTable) = True Then
            Selection.Tables(1).Range.Characters.Last.Next.Select
        End If
       
        ' Выделение строки и копирование её текста в переменную.
        Selection.Expand Unit:=wdLine
        text = LCase(Selection.text)
       
        ' Если справа буква, значит есть автоперенос текста.
        If Right(text, 1) Like "[а-яё]" Then
            ' Переход в нижнюю строку и копирование её текста в переменную.
            Selection.Move Unit:=wdLine, Count:=1
            Selection.Expand Unit:=wdLine
            text = LCase(Selection.text)
            ' Если в начале есть две русские буквы, а затем не русская буква.
            If text Like "[а-яё][а-яё][!а-яё]*" Then
                ' Закраска.
                Selection.Range.HighlightColorIndex = wdYellow
                ' Пометка.
                found = "ДА"
            End If
        Else
            ' Переход на следующую строку.
            Selection.Move Unit:=wdLine, Count:=1
            ' Если достигнут конец области.
                ' С помощью самого "Move" не получается узнать, достигнут ли конце области,
                ' т.к. используется выделение строки и ворд всегда считает, что произошёл переход
                ' на следующую строку (брак в ворде).
            If Selection.End = lngEnd Then
                Exit Sub
            End If
        End If
       
    Loop
   
End Sub
[свернуть]

Anton

Огромное спасибо!
На документе 130 листов (размер шрифта 12, одинарный интервал) отработал очень даже быстро! И я не ожидал, что таких "хвостов" у меня так много!

Уже начал думать, как автоматом убрать хвосты. Но пока ничего не придумал.
Но, все-равно, очень выручили!

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

Если в одном месте хвост уберёте, то дальше в файле могут появиться хвосты. Поэтому после изменения может потребоваться снова запускать макрос.

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

Можно пробелы добавлять. Вы выделяете строку, запускаете макрос (его надо сделать), макрос добавляет пробелы, пока не изменится конец строки.

Anton

Пробелы не подойдут. Наоборот, от лишних избавляюсь.