Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Word
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 03.07.2019, 08:13   #1
Berton3
Новичок
Джуниор
 
Регистрация: 03.07.2019
Сообщений: 1
Восклицание Довести макрос до ума

Всем привет!
Имеется макрос для замены пробелов после предлогов в конце строк на неразрывные.
Не хватает знаний в данной области чтобы довести его до ума. Прошу направить на путь истинный.

Код:
Sub KILLPREDLOG()
    ActiveDocument.ActiveWindow.View.Type = wdPrintView
    'ActiveDocument.Range(0, 0).Select
    SimpleReplaceAtEndOfLine1 Selection.Range, "(<[А-я])([ ]@<)", "\1^s" 
' эта строка отрабатывает полностью свои варианты
    SimpleReplaceAtEndOfLine1 Selection.Range, "(<[Пп,Тт,Нн,Дд]о)([ ]@<)", "\1^s" 
' эта строка стартует после первой, и отрабатывает только остаток текста
(нужно, чтобы она как и первая отработала весь текст)
    End Sub
 
Sub SimpleReplaceAtEndOfLine1(FindRange As Range, What As String, ForWhat As String)
Dim R As Word.Range
Dim EOL As Boolean
Dim N As Long
    Set R = FindRange.Duplicate
    R.Collapse Direction:=wdCollapseStart
    With R.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .MatchWildcards = True
        .Text = What
        .Replacement.Text = ForWhat
    End With
    Do While R.End < R.StoryLength - 1
        R.Collapse Direction:=wdCollapseEnd
        R.Find.Execute Replace:=wdReplaceNone
        If R.Find.Found <> True Then Exit Do
        If FindRange.Start < FindRange.End Then
            If R.InRange(FindRange) <> True Then Exit Do
        End If
        'обработка
        R.Select
        N = Selection.EndOf(Unit:=Word.wdLine, Extend:=Word.wdMove)
        EOL = Selection.IPAtEndOfLine
        If (N = 1) And EOL Then
            R.Collapse Direction:=wdCollapseStart
            R.Find.Execute Replace:=wdReplaceOne
        End If
        Loop
End Sub
Berton3 вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Довести программу до ума laucher Помощь студентам 2 15.10.2016 19:51
довести до ума ! Morgusha JavaScript, Ajax 3 18.04.2013 22:25
Довести до ума БД в delphi Харламов Юрий Помощь студентам 6 28.12.2010 02:34
Помогите довести до ума andresan Assembler - Ассемблер (FASM, MASM, WASM, NASM, GoASM, Gas, RosAsm, HLA) и не рекомендуем TASM 2 27.11.2009 07:46