Attribute VB_Name = "HTML" Sub SaveInHTML_All() Spiski DvaAbz RemoveHeadings RemoveFonts_html CareChanges SpecialSymbols HtmlAcsessStart Enotes HtmlAcsessEnd Beep End Sub Sub NChange(m1, m2 As String) 'поиск и замена нормальные Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Основной шрифт абзаца") With Selection.Find .Text = m1 .Replacement.Text = m2 .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = True .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False ' Do While .Execute .Execute Replace:=wdReplaceAll ' Loop End With Selection.Collapse End Sub Sub WChange(s1, s2 As String) 'поиск и замена с подстановочными символами With Selection.Find .Text = s1 .Replacement.Text = s2 .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = True .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll End Sub Sub DvaAbz() NChange "^p^p", "^p" End Sub Sub RemoveHeadings() 'Заменяем стили на таги заголовков 'Как-то выполнена эта задача, но пока получилось только так NombreParas = ActiveDocument.Paragraphs.Count For i = 1 To NombreParas With ActiveDocument.Paragraphs(i).Range Texte$ = .Style Select Case Texte$ Case "Normal", "Normal (Web)", "Обычный", "Обычный (Web)" Texte$ = "p" Case "Заголовок 1" Texte$ = "h1" Case "Заголовок 2" Texte$ = "h2" Case "Заголовок 3" Texte$ = "h3" Case "Заголовок 4" Texte$ = "h4" Case "Заголовок 5" Texte$ = "h5" Case "Заголовок 6" Texte$ = "h6" Case "Заголовок 7" Texte$ = "h7" Case "Заголовок 8" Texte$ = "h8" Case "Заголовок 9" Texte$ = "h9" End Select .InsertBefore "<" & Texte$ & ">" End With Next i 'заменяем на соотв. таги NChange "<Обычный>", "

" NChange "<ОБычный (Web)>", "

" NChange "<Основной текст>", "

" NChange "<Список>", "

  • " NChange "<Список 2>", "
  • " NChange "<Основной текст с отступом>", "

    " NChange "<Основной текст с отступом 1>", "

    " NChange "<Основной текст с отступом 2>", "

    " NChange "<Цитата>", "

    " NChange "

    ", "

    " 'Заголовок 1 Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles("Заголовок 1") Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Обычный") With Selection.Find .Text = "^p" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Заголовок 2 Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles("Заголовок 2") Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Обычный") With Selection.Find .Text = "^p" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Заголовок 3 Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles("Заголовок 3") Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Обычный") With Selection.Find .Text = "^p" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Заголовок 4 Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles("Заголовок 4") Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Обычный") With Selection.Find .Text = "^p" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Заголовок 5 Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles("Заголовок 5") Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Обычный") With Selection.Find .Text = "^p" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Заголовок 6 Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles("Заголовок 6") Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Обычный") With Selection.Find .Text = "^p" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Заголовок 7 Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles("Заголовок 7") Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Обычный") With Selection.Find .Text = "^p" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Заголовок 8 Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles("Заголовок 8") Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Обычный") With Selection.Find .Text = "^p" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll End Sub Sub RemoveFonts_html() 'Replace Bold Selection.Find.ClearFormatting Selection.Find.Font.Bold = True Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Основной шрифт абзаца") With Selection.Find .Text = "" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Replace Italic Selection.Find.ClearFormatting Selection.Find.Font.Italic = True Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Основной шрифт абзаца") With Selection.Find .Text = "" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Replace Underline Selection.Find.ClearFormatting Selection.Find.Font.Underline = True Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Основной шрифт абзаца") With Selection.Find .Text = "" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Replace Superscript Selection.Find.ClearFormatting Selection.Find.Font.Superscript = True Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Основной шрифт абзаца") With Selection.Find .Text = "" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Replace Subscript Selection.Find.ClearFormatting Selection.Find.Font.Superscript = True Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Основной шрифт абзаца") With Selection.Find .Text = "" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll End Sub Sub CareChanges() 'упрощаем и исправляем код 'Для замен заголовков NChange "

    ", "

    " NChange "^p

    ^p", "^p" NChange "

  • ", "
  • " NChange "

    ", "

    " NChange "^p

    ^p", "^p" NChange "

    ", "

    " NChange "^p

    ^p", "^p" NChange "

    ", "

    " NChange "^p

    ^p", "^p" NChange "

    ", "
    " NChange "^p
    ^p", "^p" NChange "

    ", "
    " NChange "^p
    ^p", "^p" NChange "

    ", "" NChange "^p^p", "^p" NChange "

    ", "" NChange "^p^p", "^p" NChange "

    ", "" NChange "^p^p", "^p" NChange "

    ", "

    " 'Для шрифтовых выделений NChange "^p", "^p" NChange "^p", "^p" NChange "^p", "^p" NChange "^p", "^p" NChange "^p", "^p" NChange "", "" NChange "", "" NChange "", "" NChange "

    ", "

    " NChange "

    ", "

    " NChange "

    ", "

    " NChange " ", " " NChange "

  • ", "
  • " NChange "

  • ", "
  • " End Sub Sub Spiski() ' сначала преобразуем списки в текст ActiveDocument.ConvertNumbersToText ' затем пытаемся списки обнаружить NChange "–^t", "
  • " Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting Selection.Find.Font.Name = "Symbol" Selection.Find.Replacement.Style = ActiveDocument.Styles("Основной шрифт абзаца") With Selection.Find With Selection.Find .Text = "^?^t" .Replacement.Text = "
  • " .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll End With End Sub Sub SpecialSymbols() WChange " {2;50}", " " ' двойные пробелы NChange " ", " " 'двойные пробелы NChange "^w^p", "^p" 'табуляция и/или пробел в конце абзаца NChange "^p^w", "^p" 'табуляция и/или пробел в начале абзаца NChange "^s ", "^s" NChange " ^s", "^s" WChange " о. ", " о.^s" 'приклеиваем о. (отец) WChange "(С.)([1-9])", "\1^s\2" 'пробел перед цифрой после С. WChange "(С.)(^32)([1-9])", "\1^s\3" 'меняем пробел перед цифрой после С. WChange "([0-9]) (г)", "\1^s\2" 'вставляем неразрывный между цифрой и г NChange "", "" NChange "н. э.", "н.^sэ." NChange "^s", " " NChange "^l", "^l
    " End Sub Sub HtmlAcsessStart() '////////////// 'Помещает обязательные строки в начало документа. Проверяет, если таковые уже существуют '////////////// Const HtmlString As String = "" & vbCr Dim TestRg As Range Selection.HomeKey Unit:=wdStory Set TestRg = ActiveDocument.Paragraphs(1).Range If TestRg.Text <> HtmlString Then Selection.TypeText "" & vbCr Selection.TypeText "" & vbCr Selection.TypeText "" & vbCr Selection.TypeText Text:="New Document" Selection.TypeParagraph Selection.TypeText Text:="" Selection.TypeParagraph Selection.TypeText Text:="" Selection.TypeParagraph Selection.TypeText Text:="" & vbCr Selection.TypeText "" End If End Sub Sub HtmlAcsessEnd() Const HtmlEnd As String = "" & vbCr Dim TestRg As Range i = ActiveDocument.Paragraphs.Count Selection.EndKey Unit:=wdStory Set TestRg = ActiveDocument.Paragraphs(i).Range If TestRg.Text <> HtmlEnd Then Selection.EndKey Unit:=wdStory Selection.TypeParagraph Selection.TypeText "" & vbCr & "" End If End Sub Sub Enotes() 'Пытаюсь переписать Финкельштейна ActiveDocument.Footnotes.Convert ' With ActiveDocument.Footnotes ' .Location = wdBottomOfPage ' .NumberingRule = wdRestartContinuous ' .StartingNumber = 1 ' .NumberStyle = wdNoteNumberStyleArabic ' End With ' With ActiveDocument.Endnotes ' .Location = wdEndOfDocument ' .NumberingRule = wdRestartContinuous ' .StartingNumber = 1 ' .NumberStyle = wdNoteNumberStyleArabic ' End With n = ActiveDocument.Endnotes.Count If n = 0 Then Application.StatusBar = _ "В этом документе нет сносок, заканчиваем процедуру!" Exit Sub End If i = 1 While ActiveDocument.Endnotes.Count > 0 ActiveDocument.Endnotes(1).Range.Select NChange "^p", "

    ^p" NChange "^l", "
    " ActiveDocument.Endnotes(1).Range.Select ' вид сноски в документе: ' номер сноски Selection.Copy ActiveDocument.Endnotes(1).Reference.Select Selection.InsertBefore "" _ & "" & i & "" 'идем в конец Selection.EndKey Unit:=wdStory Selection.TypeParagraph ' а так выглядит строка в конце: '

    номер сноски (назад) текст сноски

    Selection.InsertBefore "

    " _ & "" & i & "" Selection.EndKey Unit:=wdLine Selection.Paste Selection.TypeText "

    " ActiveDocument.Endnotes(1).Delete i = i + 1 Wend End Sub