Option Explicit Public what As String Public forwhat As String Public checkCase As Boolean Public exitPoint As Boolean Public CaRet As String Public FileName1 As String Public i As Integer Public j As Integer Public vol As Long Function impossible() As Boolean If Err Then MsgBox "Выполнение модуля невозможно: ни один документ не открыт.", vbCritical, "" Err.Clear impossible = True Else impossible = False End If End Function Sub SimpleReplace(what, forwhat, checkCase) exitPoint = False With Selection With .Find .ClearFormatting .Text = what .Replacement.ClearFormatting .Replacement.Text = forwhat .Forward = True .Wrap = wdFindContinue .MatchCase = checkCase .MatchWildcards = False 'NEW .Execute Replace:=wdReplaceAll If Not .Found Then exitPoint = True End If End With End With End Sub Sub ReplaceOnce(what, forwhat) exitPoint = False With Selection With .Find .ClearFormatting .Text = what .Replacement.ClearFormatting .Replacement.Text = forwhat .Forward = True .Wrap = wdFindContinue .MatchCase = checkCase .MatchWildcards = False 'NEW .Execute Replace:=wdReplaceOne If Not .Found Then exitPoint = True End If End With End With End Sub Sub RightTypography() On Error Resume Next CaRet = Chr(10) + Chr(13) With ActiveDocument If impossible Then 'NEW Exit Sub End If .Save FileName1 = .FullName .Close End With Documents.Open FileName1 'NEW CleanUp NMDash NoBreak NoBreakSurahAyah NoBreakSalawats If MsgBox("Упорядочить рисунок кавычек?", vbYesNo, "") = vbYes Then SetQuotes 'NEW End If MsgBox "Работа макроса завершена. Если её результаты чем-то не устраивают, можно просто закрыть файл без сохранения: " _ & CaRet & "все последствия работы макроса будут ликвидированы (пользовательские изменения, сделанные до начала работы макроса, сохранены).", vbInformation, "" End Sub Sub CleanUp() ' deletion tabs = удаление табуляции If MsgBox("Удалить табуляцию?", vbYesNo, "") = vbYes Then SimpleReplace "^t", " ", True End If ' punctuation spaces = пробелы при знаках препинания If MsgBox("Упорядочить пробелы при знаках препинания?", vbYesNo, "") = vbYes Then SimpleReplace "(", " (", True SimpleReplace "( ", "(", True SimpleReplace ")", ") ", True SimpleReplace " )", ")", True SimpleReplace "- (", "-(", True SimpleReplace ") -", ")-", True SimpleReplace "!", "! ", True SimpleReplace " !", "!", True SimpleReplace "?", "? ", True SimpleReplace " ?", "?", True SimpleReplace ".", ". ", True SimpleReplace " .", ".", True SimpleReplace ",", ", ", True SimpleReplace " ,", ",", True SimpleReplace ":", ": ", True SimpleReplace " :", ":", True SimpleReplace ". ru", ".ru", True SimpleReplace ". com", ".com", True SimpleReplace ". net", ".net", True SimpleReplace ". org", ".org", True End If ' deletion multiple spaces = удаление кратных пробелов Do SimpleReplace " ", " ", True If exitPoint Then Exit Do End If Loop ' deletion spaces which start a paragraph = удаление пробелов, начинающих абзац SimpleReplace "^p ", "^p", True ' deletion spaces which end a paragraph = удаление пробелов, заканчивающих абзац SimpleReplace " ^p", "^p", True ' deletion manual line breaks = удаление ручных переводов строки Select Case MsgBox("Заменить ручной перевод строки (Shift+Enter)? " _ & CaRet & "Пробелом (Да), знаком абзаца (Нет), не заменять (Отмена)", vbYesNoCancel, "") 'NEW Case vbYes SimpleReplace "^l", " ", True Case vbNo SimpleReplace "^l", "^p", True End Select ' deletion blank paragraphs ending the text = удаление пустых строк в конце текста 'NEW Do With Selection .HomeKey Unit:=wdStory vol = .EndOf(Unit:=wdStory) + 1 If vol = ActiveDocument.ComputeStatistics(wdStatisticCharactersWithSpaces) + ActiveDocument.ComputeStatistics(wdStatisticParagraphs) Then Exit Do Else .TypeBackspace End If End With Loop ' deletion blank lines = удаление пустых строк в середине текста If MsgBox("Убираем пустые строки?", vbYesNo, "") = vbYes Then 'NEW Do SimpleReplace "^p^p", "^p", True If exitPoint Then Exit Do End If Loop End If exitPoint = False End Sub Sub NMDash() ' m-dash as a punctuation mark = длинное тире как знак препинания SimpleReplace " - ", " ^+ ", True SimpleReplace " -^p", " ^+^p", True 'NEW SimpleReplace " ^= ", " ^+ ", True SimpleReplace " ^=^p", " ^+^p", True 'NEW ' m-dash as a dialogue mark = длинное тире как знак прямой речи в диалогах SimpleReplace "^p- ", "^p^+ ", True SimpleReplace "^p^= ", "^p^+ ", True ' n-dash as an interspace = короткое тире как интервальное If MsgBox("Постановка интервального тире выполняется экстенсивно. " _ & CaRet & "Продолжить (Да), пропустить (Нет)?", vbYesNo, "") = vbYes Then Do With Selection .HomeKey Unit:=wdStory With .Find .ClearFormatting .Forward = True .Wrap = wdFindStop .Text = "^#-^#" .Execute If Not .Found Then Exit Do End If End With .MoveLeft .MoveRight .Delete .TypeText ("–") End With Loop End If ' omission dots sign istead of three points = многоточие вместо трёх точек SimpleReplace "...", "…", True End Sub Sub NoBreak() ' deabbreviation = расшифровка сокращений SimpleReplace "т.е.", "то есть", True SimpleReplace "т. е.", "то есть", True SimpleReplace "Т.е.", "То есть", True SimpleReplace "Т. е.", "то есть", True SimpleReplace "в т.ч.", "в том числе", True SimpleReplace "в т. ч.", "в том числе", True ' nbsp in abbreviations = неразрывный пробел в сокращениях SimpleReplace "и т.д.", "и^sт.^sд.", True SimpleReplace "И т.д.", "И^sт.^sд.", True SimpleReplace "и т.п.", "и^sт.^sп.", True SimpleReplace "И т.п.", "И^sт.^sп.", True SimpleReplace "г.х.", "г.^sх.", True SimpleReplace "н.э.", "н.^sэ.", True SimpleReplace "и т. д.", "и^sт.^sд.", True SimpleReplace "И т. д.", "И^sт.^sд.", True SimpleReplace "и т. п.", "и^sт.^sп.", True SimpleReplace "И т. п.", "И^sт.^sп.", True SimpleReplace "г. х.", "г.^sх.", True SimpleReplace "н. э.", "н.^sэ.", True ' nbsp after prepositions = неразрывный пробел после предлогов SimpleReplace " в ", " в^s", True SimpleReplace " В ", " В^s", True SimpleReplace " к ", " к^s", True SimpleReplace " К ", " К^s", True SimpleReplace " о ", " о^s", True SimpleReplace " О ", " О^s", True SimpleReplace " с ", " с^s", True SimpleReplace " С ", " С^s", True SimpleReplace " у ", " у^s", True SimpleReplace " У ", " У^s", True SimpleReplace "(в ", "(в^s", True SimpleReplace "(В ", "(В^s", True SimpleReplace "(к ", "(к^s", True SimpleReplace "(К ", "(К^s", True SimpleReplace "(о ", "(о^s", True SimpleReplace "(О ", "(О^s", True SimpleReplace "(с ", "(с^s", True SimpleReplace "(С ", "(С^s", True SimpleReplace "(у ", "(у^s", True SimpleReplace "(У ", "(У^s", True SimpleReplace "[в ", "[в^s", True SimpleReplace "[В ", "[В^s", True SimpleReplace "[к ", "[к^s", True SimpleReplace "[К ", "[К^s", True SimpleReplace "[о ", "[о^s", True SimpleReplace "[О ", "[О^s", True SimpleReplace "[с ", "[с^s", True SimpleReplace "[С ", "[С^s", True SimpleReplace "[у ", "[у^s", True SimpleReplace "[У ", "[У^s", True SimpleReplace ChrW(171) & "в ", ChrW(171) & "в^s", True SimpleReplace ChrW(171) & "В ", ChrW(171) & "В^s", True SimpleReplace ChrW(171) & "к ", ChrW(171) & "к^s", True SimpleReplace ChrW(171) & "К ", ChrW(171) & "К^s", True SimpleReplace ChrW(171) & "о ", ChrW(171) & "о^s", True SimpleReplace ChrW(171) & "О ", ChrW(171) & "О^s", True SimpleReplace ChrW(171) & "с ", ChrW(171) & "с^s", True SimpleReplace ChrW(171) & "С ", ChrW(171) & "С^s", True SimpleReplace ChrW(171) & "у ", ChrW(171) & "у^s", True SimpleReplace ChrW(171) & "У ", ChrW(171) & "У^s", True SimpleReplace ChrW(8220) & "в ", ChrW(8220) & "в^s", True SimpleReplace ChrW(8220) & "В ", ChrW(8220) & "В^s", True SimpleReplace ChrW(8220) & "к ", ChrW(8220) & "к^s", True SimpleReplace ChrW(8220) & "К ", ChrW(8220) & "К^s", True SimpleReplace ChrW(8220) & "о ", ChrW(8220) & "о^s", True SimpleReplace ChrW(8220) & "О ", ChrW(8220) & "О^s", True SimpleReplace ChrW(8220) & "с ", ChrW(8220) & "с^s", True SimpleReplace ChrW(8220) & "С ", ChrW(8220) & "С^s", True SimpleReplace ChrW(8220) & "у ", ChrW(8220) & "у^s", True SimpleReplace ChrW(8220) & "У ", ChrW(8220) & "У^s", True SimpleReplace ChrW(8249) & "в ", ChrW(8249) & "в^s", True SimpleReplace ChrW(8249) & "В ", ChrW(8249) & "В^s", True SimpleReplace ChrW(8249) & "к ", ChrW(8249) & "к^s", True SimpleReplace ChrW(8249) & "К ", ChrW(8249) & "К^s", True SimpleReplace ChrW(8249) & "о ", ChrW(8249) & "о^s", True SimpleReplace ChrW(8249) & "О ", ChrW(8249) & "О^s", True SimpleReplace ChrW(8249) & "с ", ChrW(8249) & "с^s", True SimpleReplace ChrW(8249) & "С ", ChrW(8249) & "С^s", True SimpleReplace ChrW(8249) & "у ", ChrW(8249) & "у^s", True SimpleReplace ChrW(8249) & "У ", ChrW(8249) & "У^s", True SimpleReplace ChrW(8216) & "в ", ChrW(8216) & "в^s", True SimpleReplace ChrW(8216) & "В ", ChrW(8216) & "В^s", True SimpleReplace ChrW(8216) & "к ", ChrW(8216) & "к^s", True SimpleReplace ChrW(8216) & "К ", ChrW(8216) & "К^s", True SimpleReplace ChrW(8216) & "о ", ChrW(8216) & "о^s", True SimpleReplace ChrW(8216) & "О ", ChrW(8216) & "О^s", True SimpleReplace ChrW(8216) & "с ", ChrW(8216) & "с^s", True SimpleReplace ChrW(8216) & "С ", ChrW(8216) & "С^s", True SimpleReplace ChrW(8216) & "у ", ChrW(8216) & "у^s", True SimpleReplace ChrW(8216) & "У ", ChrW(8216) & "У^s", True ' nbsp after conjunctions = неразрывный пробел после союзов SimpleReplace " а ", " а^s", True SimpleReplace " А ", " А^s", True SimpleReplace " и ", " и^s", True SimpleReplace " И ", " И^s", True SimpleReplace "(а ", "(а^s", True SimpleReplace "(А ", "(А^s", True SimpleReplace "(и ", "(и^s", True SimpleReplace "(И ", "(И^s", True SimpleReplace "[а ", "[а^s", True SimpleReplace "[А ", "[А^s", True SimpleReplace "[и ", "[и^s", True SimpleReplace "[И ", "[И^s", True SimpleReplace ChrW(171) & "а ", ChrW(171) & "а^s", True SimpleReplace ChrW(171) & "А ", ChrW(171) & "А^s", True SimpleReplace ChrW(171) & "и ", ChrW(171) & "и^s", True SimpleReplace ChrW(171) & "И ", ChrW(171) & "И^s", True SimpleReplace ChrW(8220) & "а ", ChrW(8220) & "а^s", True SimpleReplace ChrW(8220) & "А ", ChrW(8220) & "А^s", True SimpleReplace ChrW(8220) & "и ", ChrW(8220) & "и^s", True SimpleReplace ChrW(8220) & "И ", ChrW(8220) & "И^s", True SimpleReplace ChrW(8249) & "а ", ChrW(8249) & "а^s", True SimpleReplace ChrW(8249) & "А ", ChrW(8249) & "А^s", True SimpleReplace ChrW(8249) & "и ", ChrW(8249) & "и^s", True SimpleReplace ChrW(8249) & "И ", ChrW(8249) & "И^s", True SimpleReplace ChrW(8216) & "а ", ChrW(8216) & "а^s", True SimpleReplace ChrW(8216) & "А ", ChrW(8216) & "А^s", True SimpleReplace ChrW(8216) & "и ", ChrW(8216) & "и^s", True SimpleReplace ChrW(8216) & "И ", ChrW(8216) & "И^s", True ' nbsp after pronoms = неразрывный пробел после местоимений SimpleReplace " я ", " я^s", True SimpleReplace " Я ", " Я^s", True SimpleReplace "(я ", "(я^s", True SimpleReplace "(Я ", "(Я^s", True SimpleReplace "[я ", "[я^s", True SimpleReplace "[Я ", "[Я^s", True SimpleReplace ChrW(171) & "я ", ChrW(171) & "я^s", True SimpleReplace ChrW(171) & "Я ", ChrW(171) & "Я^s", True SimpleReplace ChrW(8220) & "я ", ChrW(8220) & "я^s", True SimpleReplace ChrW(8220) & "Я ", ChrW(8220) & "Я^s", True SimpleReplace ChrW(8249) & "я ", ChrW(8249) & "я^s", True SimpleReplace ChrW(8249) & "Я ", ChrW(8249) & "Я^s", True SimpleReplace ChrW(8216) & "я ", ChrW(8216) & "я^s", True SimpleReplace ChrW(8216) & "Я ", ChrW(8216) & "Я^s", True ' nbsp before dash = неразрывный пробел перед длинным тире SimpleReplace " ^+", "^s^+", True ' nbsp after digits and number sign as well as before percent sign and before slash = неразрывный пробел после цифр, знака номера, а также перед знаком процента и косой чертой SimpleReplace "%", "^s%", True SimpleReplace "№", "№^s", True SimpleReplace "^# ", "^&^s", True SimpleReplace " ^s", "^s", True SimpleReplace "^s ", "^s", True SimpleReplace " /", "^s/", True End Sub Sub SetQuotes() Dim QuotesOptions As Boolean Dim quotes1 As Boolean Dim quotes2 As Boolean Dim quotes3 As Boolean Dim quotes4 As Boolean exitPoint = False QuotesOptions = Options.AutoFormatAsYouTypeReplaceQuotes ' check if forward quotes are consistent with back ones (plus change them to double strokes) = проверка соответствия количества открывающих и закрывающих кавычек и замена их на машинописные кавычки Options.AutoFormatAsYouTypeReplaceQuotes = True SimpleReplace ChrW(8220), """", True SimpleReplace ChrW(8221), """", True Options.AutoFormatAsYouTypeReplaceQuotes = False quotes1 = True 'here: presuming there are first level quotes in the text = здесь: предположим, что кавычки в тексте есть With Selection .HomeKey Unit:=wdStory i = 0 Do ReplaceOnce ChrW(171), """" If exitPoint Then exitPoint = False Exit Do Else .MoveRight End If i = i + 1 Loop .HomeKey Unit:=wdStory j = 0 Do ReplaceOnce ChrW(187), """" If exitPoint Then exitPoint = False Exit Do Else .MoveRight End If j = j + 1 Loop End With If i <> j Then MsgBox "Количество открывающих кавычек не соответствует количеству закрывающих. Необходим ручной контроль.", , "" ActiveDocument.Undo (i + j) Options.AutoFormatAsYouTypeReplaceQuotes = QuotesOptions Exit Sub Else If i = 0 Then quotes1 = False End If End If ' change quotes = изменение рисунка кавычек If quotes1 Then With Selection .HomeKey Unit:=wdStory Options.AutoFormatAsYouTypeReplaceQuotes = True SimpleReplace """", """", True SimpleReplace "^s" & ChrW(187), "^s" & ChrW(171), True SimpleReplace ChrW(171) & ChrW(187) & ChrW(187) & ChrW(187), ChrW(171) & ChrW(171) & ChrW(171) & ChrW(171), True SimpleReplace ChrW(187) & ChrW(171) & ChrW(171) & ChrW(171), ChrW(187) & ChrW(187) & ChrW(187) & ChrW(187), True SimpleReplace ChrW(171) & ChrW(187) & ChrW(187), ChrW(171) & ChrW(171) & ChrW(171), True SimpleReplace ChrW(187) & ChrW(171) & ChrW(171), ChrW(187) & ChrW(187) & ChrW(187), True SimpleReplace ChrW(171) & ChrW(187), ChrW(171) & ChrW(171), True SimpleReplace ChrW(187) & ChrW(171), ChrW(187) & ChrW(187), True exitPoint = False quotes1 = False 'cursor is within a first level quote = курсор внутри цитаты первого уровня quotes2 = False 'cursor is within a second level quote = курсор внутри цитаты второго уровня quotes3 = False 'cursor is within a third level quote = курсор внутри цитаты третьего уровня quotes4 = False 'cursor is within a fourth level quote = курсор внутри цитаты четвёртого уровня i = 0 Do With .Find .Text = """" .Execute If Not .Found Then Exit Do End If End With If AscW(.Range) = 171 Then If quotes1 Then If quotes2 Then If quotes3 Then If quotes4 Then MsgBox "Уровень вложения более четвёртого макрос не обрабатывает. " _ & CaRet & "Работа макроса будет прервана, изменения аннулированы.", , "" ActiveDocument.Undo (i) exitPoint = True Exit Sub Else quotes4 = True .Delete .TypeText (ChrW(8216)) i = i + 2 End If Else quotes3 = True .Delete .TypeText (ChrW(8249)) i = i + 2 End If Else quotes2 = True .Delete .TypeText (ChrW(8220)) i = i + 2 End If Else quotes1 = True .MoveRight End If Else If quotes1 Then If quotes2 Then If quotes3 Then If quotes4 Then .Delete .TypeText (ChrW(8217)) i = i + 2 quotes4 = False Else .Delete .TypeText (ChrW(8250)) i = i + 2 quotes3 = False End If Else .Delete .TypeText (ChrW(8221)) i = i + 2 quotes2 = False End If Else quotes1 = False .MoveRight End If End If End If Loop End With End If Options.AutoFormatAsYouTypeReplaceQuotes = QuotesOptions End Sub