Форум по VBA, Excel и Word

Word => Макросы в Word => Тема начата: Anton от 03 Март 2017, 13:19

Название: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 03 Март 2017, 13:19
Добрый день!
А возможно ли написать макрос, который запрещает перенос в слове, если у слова на следующую строку переносится 2 буквы (например, в слове "компетенцией", может перенестись -ей).
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 03 Март 2017, 13:40
У вас в ворд-файле какие переносы сейчас: автоматические или ручные? Под ручными я понимаю не просто что юзер печатает дефисы внутри слова, а которые вставляются вордом.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 03 Март 2017, 14:22
Разметка страницы - Расстановка переносов - Авто. У меня всегда так.
Название: Re: Запретить перенос слова
Отправлено: Администратор от 03 Март 2017, 14:44
Если в самом ворде нет такой настройки, то и как правило и в макросе нет такой настройки.
Чтобы в вашем случае контролировать переносы, надо отключить в абзаце автопереносы и затем вам надо вручную расставить переносы так, как вам надо.
Ручные переносы макрос расставляет тоже с помощью диалога.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 04 Март 2017, 16:51
Понятно. Спасибо.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 04 Март 2017, 20:18
Можно попробовать найти строки, у которых в начале две русские буквы, а затем символ, не являющийся русской буквой.
Данный макрос выделяет жёлтым такие строки и в конце показывает сообщение, если были такие строки.
После работы макроса вам надо вручную просмотреть файл и сделать нужные действия вручную.
Макрос будет работать медленно, т.к. двигается по всем строкам файла от первой до последней.

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

Макрос. Версия от 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
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 06 Март 2017, 10:03
Большое спасибо! Оригинальное решение. Протестирую.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 06 Март 2017, 10:25
Протестировал. Почему-то выделяются не все строки.
Пример приложил.

[вложение удалено администратором]
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 06 Март 2017, 11:09
Тут даже дело не в макросе, а сам ворд ведёт себя неадекватно.
Выделите первую строку в файле, который вы прикрепили, и нажмите клавишу-стрелку-вниз (это делает макрос). Курсор перейдёт в строку 3, а должен перейти в строку 2. То есть брак в программе "Word".
Предполагаю, что нужно делать отдельно макрос для основного текста и отдельно для сносок.
Вам нужно отслеживать переносы в сносках?
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 06 Март 2017, 11:27
Сноски тоже нужно обрабатывать. У меня иногда они по половине страницы занимают. И такой макрос здорово выручал бы.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 06 Март 2017, 12:51
Макрос. Версия от 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
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 06 Март 2017, 15:03
Огромное спасибо!
На документе 130 листов (размер шрифта 12, одинарный интервал) отработал очень даже быстро! И я не ожидал, что таких "хвостов" у меня так много!

Уже начал думать, как автоматом убрать хвосты. Но пока ничего не придумал.
Но, все-равно, очень выручили!
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 06 Март 2017, 15:36
Если в одном месте хвост уберёте, то дальше в файле могут появиться хвосты. Поэтому после изменения может потребоваться снова запускать макрос.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 06 Март 2017, 15:41
Можно пробелы добавлять. Вы выделяете строку, запускаете макрос (его надо сделать), макрос добавляет пробелы, пока не изменится конец строки.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 06 Март 2017, 15:52
Пробелы не подойдут. Наоборот, от лишних избавляюсь.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 06 Март 2017, 15:56
Можно попробовать увеличивать расстояние между буквами: вкладка "Главная" - группа "Шрифт" - справа еле-заметная стрелка - откроется диалог - вкладка "Дополнительно" - Интервал.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 06 Март 2017, 16:16
Я об этом думал. Но тогда надо как-то подбирать сжатие или расширение. В коротких абзацах сильное сжатие или расширение испортит однообразие.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 06 Март 2017, 16:19
Макрос будет расширять шрифт в выделенной строке, пока конец строки не изменится.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 06 Март 2017, 16:21
Вы попробуйте расширить текст в том файле, который выкладывали на форуме. Разве сильно заметно?
Может быть в каких-то случаях не будет заметно.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 06 Март 2017, 21:35
Расширить многое не получится - я вручную делал. Иногда заметно.

Задачу, на мой взгляд, правильнее решать так: нужно в предыдущем слоге установить принудительно перенос (Ctrl - ). Word это поймет и перенесет слово по принудительному переносу. Это будет правильно и изящно. Но как установить такой перенос правильно? А еще, желательно, автоматически? Для меня это из области фантастики.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 06 Март 2017, 21:38
У ворда нет vba-инструментов, чтобы ставить ручные переносы. В макросе есть возможность ставить ручные переносы, но появляется диалог, какой появляется, когда юзер в самом ворде ставит ручные переносы.
То есть у вас только один вариант при установке ручных переносов - использование диалога установки ручных переносов.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 06 Март 2017, 22:11
А можно ли сделать так, чтобы слово с переносом выделялось? Я тогда попробую взять этот код (где-то нашел давно - не помню где). Может быть, получится? Правда не знаю, как убрать последний перенос в слове. Как думаете, будет работать?
По задумке так: Ваш алгоритм находит слово с переносом, алгоритм ниже расставляет принудительно переносы в слогах, а еще какой-то алгоритм убирает последний принудительный перенос в слове. И тогда получится.

Макрос
Function HyphenateWord$(ByVal text$, Optional del$ = "-")

    ' В аргумент "del" передавайте Chr(31).

    Dim sArr, sPattern, sPosition, i&, j&, k&, m$, sText$

    sArr = Array("йьъ", "аеёиоуыэюяaeiouy", "бвгджзклмнпрстфхцчшщbcdfghjklmnpqrstvwxz")
    sPattern = Split("xgg xgs xsg xss sggsg gssssg gsssg gsssg sgsg gssg sggg sggs")
    sPosition = Array(1, 1, 1, 1, 3, 3, 3, 2, 2, 2, 2, 2)

    sText = text
    For i = 1 To Len(text)
        m = LCase$(Mid$(text, i, 1))
        For j = 0 To UBound(sArr)
            If InStr(sArr(j), m) Then Mid$(text, i, 1) = Mid$("xgs", j + 1, 1): Exit For
        Next j, i

        For i = 0 To UBound(sPattern)
            j = 0
            Do
                k = InStr(j + 1, text, sPattern(i))
                If k Then
                    j = k + sPosition(i)
                    text = Left$(text, j - 1) & del & Mid$(text, j)
                    sText = Left$(sText, j - 1) & del & Mid$(sText, j)
                End If
            Loop While k
        Next i
        HyphenateWord = sText
    End Function
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 07 Март 2017, 13:34
Кроме этого макроса, в этом же модуле или в другом, должна быть ваша функция "HyphenateWord$".

Макрос
Sub Макрос()
   
    Dim var
   
   
    '1. Поиск в основном тексте.
    Call FindTransports
   
    '2. Поиск в страничных сносках.
    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
        '3) Закрытие области со сносками.
        ActiveWindow.ActivePane.Close
    End If
   
    '3. Поиск в концевых сносках.
    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
        '3) Закрытие области со сносками.
        ActiveWindow.ActivePane.Close
    End If

    '4. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

Sub FindTransports()
   
    ' Selection.MoveDown не используется, т.к. происходил перескок через строку.
        ' Это даже было в самом ворде.
    ' Selection.GoTo не используется, т.к. курсор выходит из области сносок.
   
    Dim text As String, lngEnd As Long
    Dim word As Range, trans As String
   
   
    '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
           
                ' Вставка ручных переносов и удаление последнего переноса.
                '1) Присваивание имени "word" перенесённому слову.
                Set word = Selection.Words(1)
                '2) Копирование слова в переменную.
                trans = word.text
                '3) Установка переносов в переменной "trans".
                trans = HyphenateWord$(trans, Chr(31))
                '4) Удаление последнего переноса.
                trans = StrReverse(Replace(StrReverse(trans), Chr(31), "", , 1))
                '5) Вставка слова в файл.
                word.text = trans
               
                ' Запись конца области в переменную.
                lngEnd = ActiveDocument.StoryRanges(Selection.StoryType).End - 1
               
            End If
        Else
            ' Переход на следующую строку.
            Selection.Move Unit:=wdLine, Count:=1
            ' Если достигнут конец области.
                ' С помощью самого "Move" не получается узнать, достигнут ли конце области,
                ' т.к. используется выделение строки и ворд всегда считает, что произошёл переход
                ' на следующую строку (брак в ворде).
            If Selection.End = lngEnd Then
                Exit Sub
            End If
        End If
       
    Loop
   
End Sub
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 07 Март 2017, 14:42
Большое спасибо! Все работает!
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 08 Март 2017, 21:07
Добрый вечер!
Если я ищу в начале не две, а три буквы, то строчка должна быть такой:

 If text Like "[а-яё][а-яё][а-яё][!а-яё]*" Then

Но тогда у меня макрос зацикливается. Почему так?

P.S. Или нет, не зацикливается. Не разобрался, потестирую еще.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 08 Март 2017, 21:23
Вы можете сами смотреть проблему.
Перейдите в VBA, поставьте курсор в любое место процедуры "Макрос" и нажимайте клавишу F8.
С каждым нажатием макрос будет двигаться по строкам. Кроме того, в это время вы можете заглядывать в ворд, чтобы посмотреть, что там происходит.

Из зацикливания иногда можно выйти сочетанием клавиш Ctrl+Break. Когда появится диалог, щёлкните Debug и нажимайте клавишу F8, чтобы попытаться понять, почему происходит зацикливание.

Кроме того, в режиме F8 можно наводить курсор на переменные и другие элементы кода и читать, что написано в сплывающей подсказке.

Если нет подсказки, то можно использовать Watch. Для этого нужно выделить интересующее выражение - панель Debug (её надо отобразить) - две команды, связанные с Watch.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 08 Март 2017, 21:24
Я уже дописал. Спасибо.
Просто хотел изменить алгоритм, чтобы искал или 3 или 2 буквы в начале, но, видимо, напартачил где-то.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 08 Март 2017, 22:25
Понял, когда зависает. Когда в словах уже есть принудительные переносы (когда 2 раз запускаешь).
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 08 Март 2017, 22:53
Вообщем, так и не смог придумать, как задать условие, чтобы искал 2 или 3 буквы.
Прошу помощи.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 08 Март 2017, 22:54
В режиме F8 нашли строку, на которой зависает? Почему происходит зависание?
Когда зависнет нажмите сочетание клавиш Ctrl+Break и затем нажимайте F8.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 08 Март 2017, 23:03
Вот так условие сделайте:
' Если в начале есть две или три русские буквы, а затем не русская буква.
If (text Like "[а-яё][а-яё][!а-яё]*") Or (text Like "[а-яё][а-яё][а-яё][!а-яё]*") Then
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 09 Март 2017, 07:31
Я так и делал. Но на моих текстах зависать стало часто, я подумал, что не так надо. Прерывание я активировал, смотрел: зависает в какой-то одной строчке часто и не переходит на другую строку.  Особенно, если 2-й раз прогоняешь.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 09 Март 2017, 07:46
Создайте короткий файл-пример, запустите на нём макрос, убедитесь, что есть проблема.
А затем запускайте макрос в режиме F8 и смотрите, почему перестаёт работать.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 09 Март 2017, 08:05
В во время режима F8, чтобы проскакивать некоторые моменты, ставьте точку остановки, затем нажимайте на панели зелёную стрелку (Run), когда макрос дойдёт до точки остановки, снова нажимайте F8.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 09 Март 2017, 08:35
Да я так и делал. Ни в каком-то определенном месте не застревает. А бегает цикл по кругу, около одного и того-же слова. Как-будто не переходит на другую строчку.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 09 Март 2017, 08:39
Для этого макроса можно в ворде  смотреть, что происходит в файле: нажимаете F8, затем переходите в ворд, смотрите, где курсор.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 09 Март 2017, 08:45
У меня такие мысли появляются. Что в каком-то случае у какого-то слова так и остаётся две или три буквы на следующей строке.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 09 Март 2017, 08:46
Например, зависло у меня на слове "может".
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 09 Март 2017, 08:48
А что с ним? У него три буквы перенесено и макрос это не может исправить?
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 09 Март 2017, 08:51
Внёс изменения. После вставки слова (это когда макрос расставляет переносы, а затем вставляет сформированное слово в файл), курсор переходил вверх.
Сейчас я сделал, чтобы после этого курсор переходил вниз, на следующую строку.

Для этого макроса нужен ещё ваш макрос "HyphenateWord$".

Макрос
Sub Макрос()
   
    Dim var
   
   
    '1. Поиск в основном тексте.
    Call FindTransports
   
    '2. Поиск в страничных сносках.
    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
        '3) Закрытие области со сносками.
        ActiveWindow.ActivePane.Close
    End If
   
    '3. Поиск в концевых сносках.
    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
        '3) Закрытие области со сносками.
        ActiveWindow.ActivePane.Close
    End If

    '4. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

Sub FindTransports()
   
    ' Selection.MoveDown не используется, т.к. происходил перескок через строку.
        ' Это даже было в самом ворде.
    ' Selection.GoTo не используется, т.к. курсор выходит из области сносок.
   
    Dim text As String, lngEnd As Long
    Dim word As Range, trans As String
   
   
    '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 "[а-яё][а-яё][!а-яё]*") Or (text Like "[а-яё][а-яё][а-яё][!а-яё]*") Then
           
                ' Вставка ручных переносов и удаление последнего переноса.
                '1) Присваивание имени "word" перенесённому слову.
                Set word = Selection.Words(1)
                '2) Копирование слова в переменную.
                trans = word.text
                '3) Установка переносов в переменной "trans".
                trans = HyphenateWord$(trans, Chr(31))
                '4) Удаление последнего переноса.
                trans = StrReverse(Replace(StrReverse(trans), Chr(31), "", , 1))
                '5) Вставка слова в файл.
                word.text = trans
               
                ' Запись конца области в переменную.
                lngEnd = ActiveDocument.StoryRanges(Selection.StoryType).End - 1
               
                ' Переход на следующую строку, т.к. после вставки слова, курсор переходит вверх.
                Selection.Move Unit:=wdLine, Count:=1
               
            End If
        Else
            ' Переход на следующую строку.
            Selection.Move Unit:=wdLine, Count:=1
            ' Если достигнут конец области.
                ' С помощью самого "Move" не получается узнать, достигнут ли конце области,
                ' т.к. используется выделение строки и ворд всегда считает, что произошёл переход
                ' на следующую строку (брак в ворде).
            If Selection.End = lngEnd Then
                Exit Sub
            End If
        End If
       
    Loop
   
End Sub
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 09 Март 2017, 11:17
Макрос работает! Большое спасибо!

Только вот иногда нет результата.
Скажите, а можно ли как-то отследить, убрался хвост или нет? И, если нет, запретить перенос слов в абзаце, где находилось это слово. Не ожидал, что в текстах так много слов с одним переносом.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 09 Март 2017, 11:52
Макрос
Sub Макрос()
   
    Dim var
   
   
    '1. Поиск в основном тексте.
    Call FindTransports
   
    '2. Поиск в страничных сносках.
    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
        '3) Закрытие области со сносками.
        ActiveWindow.ActivePane.Close
    End If
   
    '3. Поиск в концевых сносках.
    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
        '3) Закрытие области со сносками.
        ActiveWindow.ActivePane.Close
    End If

    '4. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

Sub FindTransports()
   
    ' Selection.MoveDown не используется, т.к. происходил перескок через строку.
        ' Это даже было в самом ворде.
    ' Selection.GoTo не используется, т.к. курсор выходит из области сносок.
   
    Dim text As String, lngEnd As Long
    Dim word As Range, trans As String
   
   
    '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 "[а-яё][а-яё][!а-яё]*") Or (text Like "[а-яё][а-яё][а-яё][!а-яё]*") Then
           
                ' Вставка ручных переносов и удаление последнего переноса.
                '1) Присваивание имени "word" перенесённому слову.
                Set word = Selection.Words(1)
                '2) Копирование слова в переменную.
                trans = word.text
                '3) Установка переносов в переменной "trans".
                trans = HyphenateWord$(trans, Chr(31))
                '4) Удаление последнего переноса.
                trans = StrReverse(Replace(StrReverse(trans), Chr(31), "", , 1))
                '5) Вставка слова в файл.
                word.text = trans
               
                ' Запись конца области в переменную.
                lngEnd = ActiveDocument.StoryRanges(Selection.StoryType).End - 1
               
                ' Выделение строки и копирование её в переменную "text".
                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 "[а-яё][а-яё][!а-яё]*") Or (text Like "[а-яё][а-яё][а-яё][!а-яё]*") Then
                        ' Отключение автопереноса в этом абзаце.
                        Selection.ParagraphFormat.Hyphenation = False
                        ' Переход в следующую строку, чтобы снять выделение, иначе будет
                            ' выделено две строки.
                        Selection.Move Unit:=wdLine, Count:=1
                    End If
                End If
            End If
        Else
            ' Переход на следующую строку.
            Selection.Move Unit:=wdLine, Count:=1
            ' Если достигнут конец области.
                ' С помощью самого "Move" не получается узнать, достигнут ли конце области,
                ' т.к. используется выделение строки и ворд всегда считает, что произошёл переход
                ' на следующую строку (брак в ворде).
            If Selection.End = lngEnd Then
                Exit Sub
            End If
        End If
       
    Loop
   
End Sub
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 09 Март 2017, 15:15
Попробуйте пожалуйста у себя позапускать несколько раз макрос с моим примером. У меня не стабильные результаты. То работает, то нет. Не могу понять. И 1 раз из 10 запрещаются переносы в абзаце.
Такой полезный макрос и хочется, чтобы стабильно работал.

[вложение удалено администратором]
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 09 Март 2017, 15:52
У меня не возникло проблем с вашим файлом. Какие у вас с ним проблемы?
На всякий случай ещё раз возьмите макрос из ответа 41.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 09 Март 2017, 16:01
У меня то срабатывает, то нет. А от производительности компьютера ничего не может зависеть?
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 09 Март 2017, 16:02
А в чём выражается "не срабатывает"?
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 09 Март 2017, 16:11
Слово "сути" из 2 слогов, должен сработать запрет на переносы в абзаце. А этот запрет возникает, если я пошагово (через F8 ) прогоняю макрос. А если не пошагово - то не срабатывает и в абзаце переносы не запрещаются.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 09 Март 2017, 16:12
Какая версия ворда у вас?
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 09 Март 2017, 16:15
Microsoft Office 2010 v.14.0.7166.5000 x32
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 09 Март 2017, 16:20
Да, у меня так же. Подумаю, что можно сделать.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 09 Март 2017, 16:33
Если поможет, то в этой строчке то выполняется условие у меня, то нет. Возможно, я ошибаюсь, но наблюдения показывают пока на нее.

If Right(text, 1) Like "[а-яё]" Then
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 09 Март 2017, 16:47
Заменил на это:
If Right(text, 1) = "у" Then
всё равно не работает.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 09 Март 2017, 17:04
У меня это в коде встречается в двух местах:
If Right(text, 1) Like "[а-яё]" Then

Во втором месте не срабатывает. Я ставлю после этого места Stop и макрос не доходит. А в режиме F8 доходит.
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Администратор от 09 Март 2017, 17:12
Проблема была из-за вставки слова. После вставки слова расположение слов было в неправильном положении.
Я добавил команду: Application.ScreenRefresh, чтобы слова встали на свои места.

Макрос
Sub Макрос()
   
    Dim var
   
   
    '1. Поиск в основном тексте.
    Call FindTransports
   
    '2. Поиск в страничных сносках.
    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
        '3) Закрытие области со сносками.
        ActiveWindow.ActivePane.Close
    End If
   
    '3. Поиск в концевых сносках.
    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
        '3) Закрытие области со сносками.
        ActiveWindow.ActivePane.Close
    End If

    '4. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

Sub FindTransports()
   
    ' Selection.MoveDown не используется, т.к. происходил перескок через строку.
        ' Это даже было в самом ворде.
    ' Selection.GoTo не используется, т.к. курсор выходит из области сносок.
   
    Dim text As String, lngEnd As Long
    Dim word As Range, trans As String
   
   
    '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 "[а-яё][а-яё][!а-яё]*") Or (text Like "[а-яё][а-яё][а-яё][!а-яё]*") Then
           
                ' Вставка ручных переносов и удаление последнего переноса.
                '1) Присваивание имени "word" перенесённому слову.
                Set word = Selection.Words(1)
                '2) Копирование слова в переменную.
                trans = word.text
                '3) Установка переносов в переменной "trans".
                trans = HyphenateWord$(trans, Chr(31))
                '4) Удаление последнего переноса.
                trans = StrReverse(Replace(StrReverse(trans), Chr(31), "", , 1))
                '5) Вставка слова в файл.
                word.text = trans
                '6) Обновление экрана, иначе в "Word 2010" неправильная разметка после вставки слова.
                Application.ScreenRefresh
               
                ' Запись конца области в переменную.
                lngEnd = ActiveDocument.StoryRanges(Selection.StoryType).End - 1
               
                ' Выделение строки и копирование её в переменную "text".
                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 "[а-яё][а-яё][!а-яё]*") Or (text Like "[а-яё][а-яё][а-яё][!а-яё]*") Then
                        ' Отключение автопереноса в этом абзаце.
                        Selection.ParagraphFormat.Hyphenation = False
                        ' Переход в следующую строку, чтобы снять выделение, иначе будет
                            ' выделено две строки.
                        Selection.Move Unit:=wdLine, Count:=1
                    End If
                End If
            End If
        Else
            ' Переход на следующую строку.
            Selection.Move Unit:=wdLine, Count:=1
            ' Если достигнут конец области.
                ' С помощью самого "Move" не получается узнать, достигнут ли конце области,
                ' т.к. используется выделение строки и ворд всегда считает, что произошёл переход
                ' на следующую строку (брак в ворде).
            If Selection.End = lngEnd Then
                Exit Sub
            End If
        End If
       
    Loop
   
End Sub
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 10 Март 2017, 08:02
Большое спасибо!
Название: Re: Word Макрос: Запретить перенос заданного количества букв
Отправлено: Anton от 10 Март 2017, 15:34
Могу я задать уточняющий вопрос? Пробую немного изучать макросы. Почему логика указанного ниже выражения именно такая?
А если справа будет стоять союз? Тоже ведь буква.

  ' Если справа буква, значит есть автоперенос текста.
        If Right(text, 1) Like "[а-яё]" Then

Догадался сам. Как-то не думал, что строки оканчиваются пробелами.