Добрый день!
А возможно ли написать макрос, который запрещает перенос в слове, если у слова на следующую строку переносится 2 буквы (например, в слове "компетенцией", может перенестись -ей).
У вас в ворд-файле какие переносы сейчас: автоматические или ручные? Под ручными я понимаю не просто что юзер печатает дефисы внутри слова, а которые вставляются вордом.
Разметка страницы - Расстановка переносов - Авто. У меня всегда так.
Если в самом ворде нет такой настройки, то и как правило и в макросе нет такой настройки.
Чтобы в вашем случае контролировать переносы, надо отключить в абзаце автопереносы и затем вам надо вручную расставить переносы так, как вам надо.
Ручные переносы макрос расставляет тоже с помощью диалога.
Понятно. Спасибо.
Можно попробовать найти строки, у которых в начале две русские буквы, а затем символ, не являющийся русской буквой.
Данный макрос выделяет жёлтым такие строки и в конце показывает сообщение, если были такие строки.
После работы макроса вам надо вручную просмотреть файл и сделать нужные действия вручную.
Макрос будет работать медленно, т.к. двигается по всем строкам файла от первой до последней.
Макрос работает в основной части файла и во всех видах сносок. Таблицы не обрабатываются.
Макрос работает только с автоматическими переносами; такие переносы видны на мониторе (в виде дефиса), но фактически дефисов нет.
Макрос. Версия от 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
Большое спасибо! Оригинальное решение. Протестирую.
Протестировал. Почему-то выделяются не все строки.
Пример приложил.
[вложение удалено администратором]
Тут даже дело не в макросе, а сам ворд ведёт себя неадекватно.
Выделите первую строку в файле, который вы прикрепили, и нажмите клавишу-стрелку-вниз (это делает макрос). Курсор перейдёт в строку 3, а должен перейти в строку 2. То есть брак в программе "Word".
Предполагаю, что нужно делать отдельно макрос для основного текста и отдельно для сносок.
Вам нужно отслеживать переносы в сносках?
Сноски тоже нужно обрабатывать. У меня иногда они по половине страницы занимают. И такой макрос здорово выручал бы.
Макрос. Версия от 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
Огромное спасибо!
На документе 130 листов (размер шрифта 12, одинарный интервал) отработал очень даже быстро! И я не ожидал, что таких "хвостов" у меня так много!
Уже начал думать, как автоматом убрать хвосты. Но пока ничего не придумал.
Но, все-равно, очень выручили!
Если в одном месте хвост уберёте, то дальше в файле могут появиться хвосты. Поэтому после изменения может потребоваться снова запускать макрос.
Можно пробелы добавлять. Вы выделяете строку, запускаете макрос (его надо сделать), макрос добавляет пробелы, пока не изменится конец строки.
Пробелы не подойдут. Наоборот, от лишних избавляюсь.
Можно попробовать увеличивать расстояние между буквами: вкладка "Главная" - группа "Шрифт" - справа еле-заметная стрелка - откроется диалог - вкладка "Дополнительно" - Интервал.
Я об этом думал. Но тогда надо как-то подбирать сжатие или расширение. В коротких абзацах сильное сжатие или расширение испортит однообразие.
Макрос будет расширять шрифт в выделенной строке, пока конец строки не изменится.
Вы попробуйте расширить текст в том файле, который выкладывали на форуме. Разве сильно заметно?
Может быть в каких-то случаях не будет заметно.
Расширить многое не получится - я вручную делал. Иногда заметно.
Задачу, на мой взгляд, правильнее решать так: нужно в предыдущем слоге установить принудительно перенос (Ctrl - ). Word это поймет и перенесет слово по принудительному переносу. Это будет правильно и изящно. Но как установить такой перенос правильно? А еще, желательно, автоматически? Для меня это из области фантастики.
У ворда нет vba-инструментов, чтобы ставить ручные переносы. В макросе есть возможность ставить ручные переносы, но появляется диалог, какой появляется, когда юзер в самом ворде ставит ручные переносы.
То есть у вас только один вариант при установке ручных переносов - использование диалога установки ручных переносов.
А можно ли сделать так, чтобы слово с переносом выделялось? Я тогда попробую взять этот код (где-то нашел давно - не помню где). Может быть, получится? Правда не знаю, как убрать последний перенос в слове. Как думаете, будет работать?
По задумке так: Ваш алгоритм находит слово с переносом, алгоритм ниже расставляет принудительно переносы в слогах, а еще какой-то алгоритм убирает последний принудительный перенос в слове. И тогда получится.
Макрос
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
Кроме этого макроса, в этом же модуле или в другом, должна быть ваша функция "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
Большое спасибо! Все работает!
Добрый вечер!
Если я ищу в начале не две, а три буквы, то строчка должна быть такой:
If text Like "[а-яё][а-яё][а-яё][!а-яё]*" Then
Но тогда у меня макрос зацикливается. Почему так?
P.S. Или нет, не зацикливается. Не разобрался, потестирую еще.
Вы можете сами смотреть проблему.
Перейдите в VBA, поставьте курсор в любое место процедуры "Макрос" и нажимайте клавишу F8.
С каждым нажатием макрос будет двигаться по строкам. Кроме того, в это время вы можете заглядывать в ворд, чтобы посмотреть, что там происходит.
Из зацикливания иногда можно выйти сочетанием клавиш Ctrl+Break. Когда появится диалог, щёлкните Debug и нажимайте клавишу F8, чтобы попытаться понять, почему происходит зацикливание.
Кроме того, в режиме F8 можно наводить курсор на переменные и другие элементы кода и читать, что написано в сплывающей подсказке.
Если нет подсказки, то можно использовать Watch. Для этого нужно выделить интересующее выражение - панель Debug (её надо отобразить) - две команды, связанные с Watch.
Я уже дописал. Спасибо.
Просто хотел изменить алгоритм, чтобы искал или 3 или 2 буквы в начале, но, видимо, напартачил где-то.
Понял, когда зависает. Когда в словах уже есть принудительные переносы (когда 2 раз запускаешь).
Вообщем, так и не смог придумать, как задать условие, чтобы искал 2 или 3 буквы.
Прошу помощи.
В режиме F8 нашли строку, на которой зависает? Почему происходит зависание?
Когда зависнет нажмите сочетание клавиш Ctrl+Break и затем нажимайте F8.
Вот так условие сделайте:
' Если в начале есть две или три русские буквы, а затем не русская буква.
If (text Like "[а-яё][а-яё][!а-яё]*") Or (text Like "[а-яё][а-яё][а-яё][!а-яё]*") Then
Я так и делал. Но на моих текстах зависать стало часто, я подумал, что не так надо. Прерывание я активировал, смотрел: зависает в какой-то одной строчке часто и не переходит на другую строку. Особенно, если 2-й раз прогоняешь.
Создайте короткий файл-пример, запустите на нём макрос, убедитесь, что есть проблема.
А затем запускайте макрос в режиме F8 и смотрите, почему перестаёт работать.
В во время режима F8, чтобы проскакивать некоторые моменты, ставьте точку остановки, затем нажимайте на панели зелёную стрелку (Run), когда макрос дойдёт до точки остановки, снова нажимайте F8.
Да я так и делал. Ни в каком-то определенном месте не застревает. А бегает цикл по кругу, около одного и того-же слова. Как-будто не переходит на другую строчку.
Для этого макроса можно в ворде смотреть, что происходит в файле: нажимаете F8, затем переходите в ворд, смотрите, где курсор.
У меня такие мысли появляются. Что в каком-то случае у какого-то слова так и остаётся две или три буквы на следующей строке.
Например, зависло у меня на слове "может".
А что с ним? У него три буквы перенесено и макрос это не может исправить?
Внёс изменения. После вставки слова (это когда макрос расставляет переносы, а затем вставляет сформированное слово в файл), курсор переходил вверх.
Сейчас я сделал, чтобы после этого курсор переходил вниз, на следующую строку.
Для этого макроса нужен ещё ваш макрос "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
Макрос работает! Большое спасибо!
Только вот иногда нет результата.
Скажите, а можно ли как-то отследить, убрался хвост или нет? И, если нет, запретить перенос слов в абзаце, где находилось это слово. Не ожидал, что в текстах так много слов с одним переносом.
Макрос
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
Попробуйте пожалуйста у себя позапускать несколько раз макрос с моим примером. У меня не стабильные результаты. То работает, то нет. Не могу понять. И 1 раз из 10 запрещаются переносы в абзаце.
Такой полезный макрос и хочется, чтобы стабильно работал.
[вложение удалено администратором]
У меня не возникло проблем с вашим файлом. Какие у вас с ним проблемы?
На всякий случай ещё раз возьмите макрос из ответа 41.
У меня то срабатывает, то нет. А от производительности компьютера ничего не может зависеть?
А в чём выражается "не срабатывает"?
Слово "сути" из 2 слогов, должен сработать запрет на переносы в абзаце. А этот запрет возникает, если я пошагово (через F8 ) прогоняю макрос. А если не пошагово - то не срабатывает и в абзаце переносы не запрещаются.
Какая версия ворда у вас?
Microsoft Office 2010 v.14.0.7166.5000 x32
Да, у меня так же. Подумаю, что можно сделать.
Если поможет, то в этой строчке то выполняется условие у меня, то нет. Возможно, я ошибаюсь, но наблюдения показывают пока на нее.
If Right(text, 1) Like "[а-яё]" Then
Заменил на это:
If Right(text, 1) = "у" Then
всё равно не работает.
У меня это в коде встречается в двух местах:
If Right(text, 1) Like "[а-яё]" Then
Во втором месте не срабатывает. Я ставлю после этого места Stop и макрос не доходит. А в режиме F8 доходит.
Проблема была из-за вставки слова. После вставки слова расположение слов было в неправильном положении.
Я добавил команду: 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
Большое спасибо!
Могу я задать уточняющий вопрос? Пробую немного изучать макросы. Почему логика указанного ниже выражения именно такая?
А если справа будет стоять союз? Тоже ведь буква.
' Если справа буква, значит есть автоперенос текста.
If Right(text, 1) Like "[а-яё]" Then
Догадался сам. Как-то не думал, что строки оканчиваются пробелами.