Attribute VB_Name = "RAZDELENIE"
Sub RAZDELENIE()
' Разбивка документа на части и компиляция сайта
' Для разбивки можно использовать заголовки 2 и 1 уровня. Разделы под заголовками
' первого уровня распределяются по отдельным папкам.
' При этом в текущей папке будет файл index.htm,
' содержащий оглавление и название, если первый абзац имеет стиль Заголовок 1
' Макрос записан 19.02.03
' Copyright 2003 Столпянский Виктор Юрьевич
' http://uspp.narod.ru
' ShareWare Product 5 WM

    Dim Fldr, TR, OglPlace, g, D, I, J, K
    Dim L, CNT, sm, name
      
    Fldr = ActiveDocument.path
    name = ActiveDocument.name
    name = Left(name, (Len(name) - 4))
    g = "g"                  'определение имен файлов первого уровня
    D = "d"                  'определение имен файлов второго уровня
    sm = 1
 TR = MsgBox("Да, для разбивки используем только заголовки 2 уровня" + Chr(13) + "Нет  - разделы заголовков первого уровня" + Chr(13) + "будут распределены по папкам. В текущей папке" + Chr(13) + "останется файл index.htm, содержащий оглавление и название," + Chr(13) + "взятое из первого абзаца документа" + Chr(13) + "Отмена - свалить все HTML в одну кучу," + Chr(13) + "а рисунки в отдельную папку", vbExclamation + vbYesNoCancel + 256, "Разбивка документа на части")
 OglPlace = MsgBox("Да, хотим ссылки третьего уровня поместить в index.htm?" + Chr(13) + "Нет - поместить в оглавлении подразделов первого уровня" + Chr(13) + "Отмена - индекс в начале подразделов второго уровня" + Chr(13) + "(Если эти ссылки не нужны закомментируйте в макросе)", vbExclamation + vbYesNoCancel + 256, "Определение положения индекса третьего уровня")
    ActiveDocument.Paragraphs(1).Range.Style = "Обычный"
    'Selection.Collapse Direction:=wdCollapseEnd

  'Cоздание оглавления
   If OglPlace = vbYes Then    ' Нажата кнопка "Да" (Yes).
    L = I
    Call index(".\", 1, 3, Fldr, TR, OglPlace, g, D, I, J, K, L)
    
    Else                        ' Нажата кнопка "Нет" (No).
    
    Call index(".\", 1, 2, Fldr, TR, OglPlace, g, D, I, J, K, L)
    
    End If
    
    If TR = vbYes Then
        Call CutSection2(Fldr, TR, OglPlace, g, D, I, J, K, CNT)
    Else
        Call CutSection1(Fldr, TR, OglPlace, g, D, I, J, K)
    End If
'______ !ATTENTION!_________значение FileFormat для типа HTML
'______ !ВНИМАНИЕ !_________может отличаться на разных системах
'______ !ВНИМАНИЕ !_________Запишите макрос сохранения в формат HTML и замените значение везде (3 шт.)

        ActiveDocument.SaveAs FileName:=Fldr & "\index.htm", FileFormat:=102, LockComments _
        :=False, Password:="", AddToRecentFiles:=True, WritePassword:="", _
        ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
        SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False
    ActiveWindow.Close
End:
End Sub
'Блок формирования гипертекстового оглавления
Sub index(pth, x, y, Fldr, TR, OglPlace, g, D, I, J, K, schet)  ' x, y - диапазон оглавления
Dim k1, CNT
 'Создание гиперссылок c оглавления
 I = 0
 J = 1
 K = 1
 k1 = 0
 CNT = 2
    Selection.HomeKey Unit:=wdStory
    Selection.MoveDown Unit:=wdParagraph, count:=1
    Selection.TypeParagraph
    Selection.MoveUp Unit:=wdParagraph, count:=1
    'Selection.Collapse Direction:=wdCollapseEnd
    With ActiveDocument
        .TablesOfContents.Add Range:=Selection.Range, RightAlignPageNumbers:= _
            False, UseHeadingStyles:=True, _
            UpperHeadingLevel:=x, _
            LowerHeadingLevel:=y, IncludePageNumbers:=False, AddedStyles:=""
        .TablesOfContents(1).TabLeader = wdTabLeaderDots
   End With
   Selection.MoveUp Unit:=wdLine, count:=1, Extend:=wdExtend
   Selection.Fields.Unlink
   Selection.Collapse Direction:=wdCollapseStart

Do Until k1 = 2
Set myRange = ActiveDocument.Range(Start:=ActiveDocument.Paragraphs(CNT).Range.Start, End:=(ActiveDocument.Paragraphs(CNT).Range.End - 1))
  If ActiveDocument.Paragraphs(CNT).Range.Style = "Оглавление 1" Then
       If TR = vbNo Then
          I = I + 1
          ActiveDocument.Hyperlinks.Add Anchor:=myRange, _
            Address:=CVar(pth & g & I), _
            SubAddress:=""
       Else
         If TR = vbCancel Then
            I = I + 1
          ActiveDocument.Hyperlinks.Add Anchor:=myRange, _
            Address:=CVar(g & I & ".htm"), _
            SubAddress:=""
         End If
       End If
       J = 1
       K = 1
       k1 = 1
       CNT = CNT + 1
  Else
     If ActiveDocument.Paragraphs(CNT).Range.Style = "Оглавление 2" Then
       If TR = vbYes Then
          ActiveDocument.Hyperlinks.Add Anchor:=myRange, _
            Address:=CVar(D & J & ".htm"), _
            SubAddress:=""
       End If
       If TR = vbNo Then
         If I < 1 Then
          ActiveDocument.Hyperlinks.Add Anchor:=myRange, _
            Address:=CVar(pth & D & J & ".htm"), SubAddress:=""
         Else
          ActiveDocument.Hyperlinks.Add Anchor:=myRange, _
            Address:=CVar(pth & g & I & "\" & D & J & ".htm"), SubAddress:=""
         End If
       End If
       If TR = vbCancel Then
          ActiveDocument.Hyperlinks.Add Anchor:=myRange, _
            Address:=CVar(g & schet & D & J & ".htm"), SubAddress:=""
       End If
        J = J + 1
        K = 1
        k1 = 1
        CNT = CNT + 1
     Else
       If ActiveDocument.Paragraphs(CNT).Range.Style = "Оглавление 3" Then
        If k1 = 0 Then
           ActiveDocument.Hyperlinks.Add Anchor:=myRange, _
           Address:="", _
           SubAddress:=CVar(K)
        Else
         If TR = vbYes Then
           ActiveDocument.Hyperlinks.Add Anchor:=myRange, _
           Address:=CVar(D & J - 1 & ".htm"), _
           SubAddress:=CVar(K)
         End If
         If TR = vbNo Then
          If I < 1 Then
           ActiveDocument.Hyperlinks.Add Anchor:=myRange, _
             Address:=CVar(pth & D & J - 1 & ".htm"), _
           SubAddress:=CVar(K)
          Else
           ActiveDocument.Hyperlinks.Add Anchor:=myRange, _
             Address:=CVar(pth & g & I & "\" & D & J - 1 & ".htm"), _
           SubAddress:=CVar(K)
          End If
         End If
       If TR = vbCancel Then
          ActiveDocument.Hyperlinks.Add Anchor:=myRange, _
            Address:=CVar(g & I & D & J - 1 & ".htm"), _
          SubAddress:=CVar(K)
       End If
        End If
        K = K + 1
        CNT = CNT + 1
       Else
          Exit Do
       End If               'оглавление 3
     End If                 'оглавление 2
  End If                    'оглавление 1
Loop
End Sub
Sub CutSection1(Fldr, TR, OglPlace, g, D, I, J, K)
Dim CNT, str
If I >= 1 Then
    For CNT = I To 7 Step -1       ' выстригание с конца документа файлов
    Selection.EndKey Unit:=wdStory
    Selection.Find.Style = ActiveDocument.Styles("Заголовок 1")
    Selection.Find.Forward = False
      Selection.Find.Execute
      Selection.MoveLeft Unit:=wdCharacter, count:=1
      Selection.EndKey Unit:=wdStory, Extend:=wdExtend
      Selection.Cut
      Documents.Add
      Selection.Paste
    
    If OglPlace = vbCancel Then    ' Нажата кнопка "Да" (Yes).
    
    Call index("", 2, 2, Fldr, TR, OglPlace, g, D, I, J, K, CNT)
    
    Else                        ' Нажата кнопка "Нет" (No).
    
    Call index("", 2, 3, Fldr, TR, OglPlace, g, D, I, J, K, CNT)
    
    End If
    
    I = CNT
    
If TR = vbNo Then
   MkDir CVar(Fldr & "\" & g & I)
End If

    Call CutSection2(Fldr, TR, OglPlace, g, D, I, J, K, CNT)
    
    Selection.HomeKey Unit:=wdStory
    Selection.TypeText Text:="НАЗАД"
    Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
      If TR = vbNo Then
       ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:=CVar("../" & g & (I - 1)), SubAddress:=""
      Else
       ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:=CVar(g & (I - 1) & ".htm"), SubAddress:=""
      End If
    Selection.TypeText Text:=" | INDEX"
    Selection.MoveLeft Unit:=wdWord, count:=1, Extend:=wdExtend
    If TR = vbNo Then
       ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:="../", SubAddress:=""
    Else
      ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:="./", SubAddress:=""
    End If
    Selection.TypeText Text:=" | ВПЕРЕД"
    Selection.MoveLeft Unit:=wdWord, count:=1, Extend:=wdExtend
    If CNT < I Then
      If TR = vbNo Then
       ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:=CVar("../" & g & (CNT + 1)), SubAddress:=""
      Else
       ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:=CVar(g & (CNT + 1) & ".htm"), SubAddress:=""
      End If
    End If
    
        Call Format_HTML
          
    If TR = vbNo Then
       str = CVar(Fldr & "\" & g & I & "\" & "index.htm")
    Else
      If TR = vbCancel Then
       str = CVar(Fldr & "\" & g & CNT & ".htm")        '!!!!!!!!!!!!!!!!!!!!!!!
      Else
       str = CVar(Fldr & "\" & "index.html")            '!!!!!!!!!!!!!!!!!!!!!!!
      End If
    End If
        ActiveDocument.SaveAs FileName:=str, FileFormat:=102, LockComments _
        :=False, Password:="", AddToRecentFiles:=True, WritePassword:="", _
        ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
        SaveNativePictureFormat:=True, SaveFormsData:=False, SaveAsAOCELetter:=False
    ActiveWindow.Close
    Next CNT
  End If
End Sub

Sub CutSection2(Fldr, TR, OglPlace, g, D, I, J, K, schet)
Dim CNT, str
K = 0
If (J - 1) >= 1 Then
    For CNT = (J - 1) To 1 Step -1     ' выстригание с конца документа файлов
    Selection.EndKey Unit:=wdStory
    Selection.Find.Style = ActiveDocument.Styles("Заголовок 2")
    Selection.Find.Forward = False
      Selection.Find.Execute
      Selection.MoveLeft Unit:=wdCharacter, count:=1
      Selection.EndKey Unit:=wdStory, Extend:=wdExtend
      Selection.Cut
      Documents.Add
      Selection.Paste
  
  Selection.HomeKey Unit:=wdStory
  Selection.Find.Style = ActiveDocument.Styles("Заголовок 3")
  Selection.Find.Forward = True
perGoTo1:
    If Selection.Find.Execute Then
       K = K + 1
    ActiveDocument.Bookmarks.Add Range:=Selection.Range, name:=CVar("z" & K)
GoTo perGoTo1
    End If

    If OglPlace = vbCancel Then    ' Нажата кнопка "Да" (Yes).
    
       schet = J
          Call index("", 3, 3, Fldr, TR, OglPlace, g, D, I, J, K, schet)
       J = schet
    
    End If
    
    Selection.HomeKey Unit:=wdStory
    Selection.TypeText Text:="НАЗАД"
    Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
    If CNT = 1 Then
      If TR = vbCancel Then
        ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:=CVar(g & I & ".htm"), SubAddress:=""
      Else
        ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:="index.htm", SubAddress:=""
      End If
    Else
      If TR = vbCancel Then
        ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:=CVar(g & I & D & (CNT - 1) & ".htm"), SubAddress:=""
      Else
        ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:=CVar(D & (CNT - 1) & ".htm"), SubAddress:=""
      End If
    End If
    Selection.TypeText Text:=" | INDEX"
    Selection.MoveLeft Unit:=wdWord, count:=1, Extend:=wdExtend
    If TR = vbNo Then
       ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:="../", SubAddress:=""
    Else
      ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:="./", SubAddress:=""
    End If
    Selection.TypeText Text:=" | ВПЕРЕД"
    Selection.MoveLeft Unit:=wdWord, count:=1, Extend:=wdExtend
      If CNT = J - 1 Then
       If TR = vbCancel Then
        ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:=CVar(g & I + 1 & ".htm"), SubAddress:=""
       End If
       If TR = vbNo Then
         ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:=CVar("..\" & g & I), SubAddress:=""
       End If
      Else
         
         ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:=CVar(D & CNT + 1 & ".htm"), SubAddress:=""
       
      End If
    
    Call Format_HTML
    
    If TR = vbNo Then
       str = CVar(Fldr & "\" & g & I & "\" & D & CNT & ".htm")
    Else
      If TR = vbCancel Then
       str = CVar(Fldr & "\" & g & I & D & CNT & ".htm")  '!!!!!!!!!!!!!!!!!!!!!!!
      Else
       str = CVar(Fldr & "\" & g & I & "\" & D & CNT & ".htm")  '!!!!!!!!!!!!!!!!!!!!!!!
      End If
    End If
    ActiveDocument.SaveAs FileName:=str, FileFormat:=102, LockComments _
        :=False, Password:="", AddToRecentFiles:=True, WritePassword:="", _
        ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
        SaveNativePictureFormat:=True, SaveFormsData:=False, SaveAsAOCELetter:=False
    
    ActiveWindow.Close
    Next CNT
  End If
End Sub
Sub Format_HTML()
    Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
    Selection.Font.Underline = wdUnderlineNone
    Selection.Font.Bold = False
    Selection.Font.Italic = False
    Selection.Font.ColorIndex = wdAuto
    Selection.Copy
    Selection.MoveRight Unit:=wdCharacter, count:=1
    Selection.TypeParagraph
    Selection.HomeKey Unit:=wdStory
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    Selection.EndKey Unit:=wdStory
    Selection.TypeParagraph
    Selection.Paste
    Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
    Selection.Font.Bold = False
    Selection.Font.Italic = False
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
 
    
    Selection.WholeStory
    With Selection.ParagraphFormat
        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .FirstLineIndent = CentimetersToPoints(0)
    End With
    With Selection.Font
        .name = "Times New Roman"
        .Size = 12
        .ColorIndex = wdAuto
    End With
    Selection.LanguageID = wdRussian
    With ActiveDocument.Styles("Оглавление 2")
        .AutomaticallyUpdate = True
        .BaseStyle = "Обычный"
        .NextParagraphStyle = "Обычный"
    End With
    With ListGalleries(wdBulletGallery).ListTemplates(1).ListLevels(1)
        .NumberFormat = ChrW(61558)
        .TrailingCharacter = wdTrailingTab
        .NumberStyle = wdListNumberStyleBullet
        .NumberPosition = CentimetersToPoints(0)
        .Alignment = wdListLevelAlignLeft
        .TextPosition = CentimetersToPoints(0.63)
        .TabPosition = CentimetersToPoints(0.63)
        .ResetOnHigher = True
        .StartAt = 1
        With .Font
            .Bold = wdUndefined
            .Italic = wdUndefined
            .StrikeThrough = wdUndefined
            .Subscript = wdUndefined
            .Superscript = wdUndefined
            .Shadow = wdUndefined
            .Outline = wdUndefined
            .Emboss = wdUndefined
            .Engrave = wdUndefined
            .AllCaps = wdUndefined
            .Hidden = wdUndefined
            .Underline = wdUndefined
            .ColorIndex = wdUndefined
            .Size = wdUndefined
            .Animation = wdUndefined
            .DoubleStrikeThrough = wdUndefined
            .name = "Wingdings"
        End With
        .LinkedStyle = "Оглавление 2"
    End With
    ActiveDocument.Styles("Оглавление 2").LinkToListTemplate ListTemplate:= _
        ListGalleries(wdBulletGallery).ListTemplates(1), ListLevelNumber:=1
    With ActiveDocument.Styles("Оглавление 2")
        .AutomaticallyUpdate = True
        .BaseStyle = "Обычный"
        .NextParagraphStyle = "Обычный"
    End With
    With ListGalleries(wdBulletGallery).ListTemplates(1).ListLevels(1)
        .NumberFormat = ChrW(61558)
        .TrailingCharacter = wdTrailingTab
        .NumberStyle = wdListNumberStyleBullet
        .NumberPosition = CentimetersToPoints(0)
        .Alignment = wdListLevelAlignLeft
        .TextPosition = CentimetersToPoints(0.63)
        .TabPosition = CentimetersToPoints(0.63)
        .ResetOnHigher = True
        .StartAt = 1
        With .Font
            .Bold = wdUndefined
            .Italic = wdUndefined
            .StrikeThrough = wdUndefined
            .Subscript = wdUndefined
            .Superscript = wdUndefined
            .Shadow = wdUndefined
            .Outline = wdUndefined
            .Emboss = wdUndefined
            .Engrave = wdUndefined
            .AllCaps = wdUndefined
            .Hidden = wdUndefined
            .Underline = wdUndefined
            .ColorIndex = wdUndefined
            .Size = wdUndefined
            .Animation = wdUndefined
            .DoubleStrikeThrough = wdUndefined
            .name = "Wingdings"
        End With
        .LinkedStyle = "Оглавление 3"
    End With
    ActiveDocument.Styles("Оглавление 3").LinkToListTemplate ListTemplate:= _
        ListGalleries(wdBulletGallery).ListTemplates(1), ListLevelNumber:=1
    With ActiveDocument.Styles("Оглавление 1").ParagraphFormat
        .LeftIndent = CentimetersToPoints(1)
    End With
    With ActiveDocument.Styles("Оглавление 1")
        .AutomaticallyUpdate = True
        .BaseStyle = "Обычный"
        .NextParagraphStyle = "Обычный"
    End With
    With ActiveDocument.Styles("Оглавление 1").Font
        .name = "Times New Roman"
        .Size = 12
        .Bold = False
        .Italic = False
        .Underline = wdUnderlineNone
        .StrikeThrough = False
        .DoubleStrikeThrough = False
        .Outline = False
        .Emboss = False
        .Shadow = False
        .Hidden = False
        .SmallCaps = False
        .AllCaps = False
        .ColorIndex = wdAuto
        .Engrave = False
        .Superscript = False
        .Subscript = False
        .Scaling = 100
        .Kerning = 0
        .Animation = wdAnimationNone
    End With
    With ActiveDocument.Styles("Оглавление 1").ParagraphFormat
        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .SpaceBefore = 0
        .SpaceAfter = 0
        .LineSpacingRule = wdLineSpaceSingle
        .Alignment = wdAlignParagraphLeft
        .WidowControl = False
        .KeepWithNext = False
        .KeepTogether = False
        .PageBreakBefore = False
        .NoLineNumber = False
        .Hyphenation = True
        .FirstLineIndent = CentimetersToPoints(0)
        .OutlineLevel = wdOutlineLevelBodyText
     End With
End Sub
