Initial commit

VBAMake.txt

@@ -0,0 +1,35 @@
+# == Properties Section ==
+# configuration properties
+# use .ini format to define properties
+# mandatory properties: name, artifact_home, source_home
+
+id = Concept-Maket
+name = Концепт-Макетирование
+description = Надстройка КОНЦЕПТ для макетирования отчетов
+artifact_home = Концепт-Макетирование
+source_home = Concept-Maket
+install_home = \\fs1.concept.ru\projects\10 Автоматизация деятельности\02 Офисная автоматизация\81 Макетирование
+
+%%
+# === Build section ===
+# Available commands:
+#   build LOCAL_MANIFEST
+#   copy LOCAL_SOURCE -> [LOCAL_ARTIFACT]
+#   save_as LOCAL_ARTIFACT -> LOCAL_ARTIFACT
+#   run LOCAL_SOURCE.bat
+
+build script\manifest.txt
+copy distr\!Руководство пользователя.docx
+
+%%
+# === Install section ==
+# Available commands:
+#	install LOCAL_ARTIFACT -> [INSTALL_PATH]
+#	add_template LOCAL_ARTIFACT -> [LOCAL_TEMPLATE]
+#   run LOCAL_ARTIFACT.bat <- [PARAMETERS]
+#	run APPLICATION <- [PARAMETERS]
+
+install _Maket.dotm
+install _Maket.dotm -> \\fs1.concept.ru\Exchange\ConceptDistr\data\Add-ins\Word\_Maket.dotm
+
+install !Руководство пользователя.docx

VERSION

@@ -0,0 +1 @@
+1.1.0

script/manifest.txt

@@ -0,0 +1,97 @@
+# == Properties Section ==
+# configuration properties
+# use .ini format to define properties
+# mandatory properties: name, artifact
+
+name = _Maket.dotm
+artifact = _Maket.dotm
+
+%%
+# === Imports Section ===
+# Hierarchy of folders and files
+# Use Tabulator to mark next level in hierarchy
+# All folders are nested into SharedHome path
+
+dev
+	DevTester.bas
+
+api
+	z_PastePictureAPI.bas
+	z_LoadPictureAPI.bas
+	ex_WinAPI.bas
+	API_WordWrapper.cls
+	API_XLWrapper.cls
+	API_UserInteraction.cls
+	
+utility
+	ex_VBA.bas
+	ex_Collection.bas
+	ex_Color.bas
+	
+word
+	ex_Word.bas
+	
+ui
+	CSE_ProgressBar.frm
+
+%%
+# === Source Code Section ==
+# Hierarchy of folders and files
+# Use Tabulator to mark next level in hierarchy
+# All folders are nested into SourceHome path
+
+src
+	DevHelper.bas
+	Declarations.bas
+	Main.bas
+	MainImpl.bas
+	z_UIMessages.bas
+	z_UIRibbon.bas
+	
+	CD_Audit.bas
+	CD_AutoDesign.bas
+	CD_Colontitles.bas
+	CD_Layout.bas
+	CD_Paint.bas
+	CD_RedesignFonts.bas
+	CD_SplitTable.bas
+	CD_WordModule.bas
+	
+	IconPicker.cls
+	
+	ItemFontScale.cls
+	ItemChapter.cls
+	ItemColontitles.cls
+	
+	InfoDocument.cls
+	
+	dialogs
+		CDD_AddPict.frm
+		CDD_AutoDesign.frm
+		CDD_FontScaling.frm
+		CDD_HeaderFooter.frm
+		CDD_Paint.frm
+		CDD_RunAudit.frm
+		CDD_TableColors.frm
+		CDD_TablePrototype.frm
+
+%%
+# ===== UI Section =======
+# Pairs of path to UI elements, use " -> " delimiter
+# First component is a path relative to SourceHome\ui folders
+# Second component is internal path inside project file
+
+.rels -> _rels\.rels
+customUI.xml -> customUI\customUI.xml
+
+%%
+# === References Section ===
+# List dependencies in one of the formats
+# global : GLOBAL_NAME
+# guid : {REGISTERED_GUID}
+# file : PATH_TO_LIBRARY
+
+global : Shell32
+global : Scripting
+global : Excel
+global : MSForms

src/CD_Audit.bas

@@ -0,0 +1,288 @@
+Attribute VB_Name = "CD_Audit"
+Option Private Module
+Option Explicit
+
+Private Const RUN_HEADER_RUN$ = "Áåãàþùèé çàãîëîâîê"
+Private Const DANG_SPACES$ = "Ïðîâåðüòå îòñòóïû"
+Private Const DANG_DASH$ = "Òèðå/äåôèñ â íà÷àëå/êîíöå ñòðîêè"
+Private Const DANG_FLD$ = "Íåðàáî÷åå ïîëå"
+Private Const DANG_LISTNUM$ = "Ïðîâåðüòå íóìåðàöèþ ñïèñêà"
+Private Const DANG_PICT$ = "Ïðîâåðüòå ïîëîæåíèå ïèêòîãðàììû"
+
+Public Sub CDA_Audit()
+  Dim theDoc As Word.Document: Set theDoc = ActiveDocument
+  Call CDD_RunAudit.Init
+  Call CDD_RunAudit.Show
+  If CDD_RunAudit.isCancelled_ Or CDD_RunAudit.CountRules = 0 Then _
+    Exit Sub
+  
+  Call CSE_ProgressBar.Init("Ïðîâåðêà ìàêåòà", maxVal:=CDD_RunAudit.CountRules)
+  Call CSE_ProgressBar.ShowModeless
+
+  Dim sMessage$
+  If CDD_RunAudit.DoHeaders Then _
+    sMessage = sMessage & "Áåãàþùèõ çàãîëîâêîâ íàéäåíî: " & CheckHeaders(theDoc) & vbNewLine
+  If CDD_RunAudit.DoPar Then _
+    sMessage = sMessage & "Íåêîððåòíûõ îòñòóïîâ íàéäåíî: " & CheckSpaces(theDoc) & vbNewLine
+  If CDD_RunAudit.DoDash Then _
+    sMessage = sMessage & "Îìåðçèòåëüíûõ òèðå íàéäåíî: " & CheckDashes(theDoc) & vbNewLine
+  If CDD_RunAudit.DoFields Then _
+    sMessage = sMessage & "Íåðàáî÷èõ ïîëåé íàéäåíî: " & CheckFields(theDoc) & vbNewLine
+  If CDD_RunAudit.DoListNums Then _
+    sMessage = sMessage & "Ðàçíóìåðîâàííûõ ñïèñêîâ íàéäåíî:" & CheckNumerList(theDoc) & vbNewLine
+  If CDD_RunAudit.DoPict Then _
+    sMessage = sMessage & "Îïàñíûõ ïèêòîãðàìì íàéäåíî:" & CheckPict(theDoc) & vbNewLine
+  
+  Call Unload(CDD_RunAudit)
+  Call Unload(CSE_ProgressBar)
+  Call MsgBox(sMessage, vbInformation)
+End Sub
+
+' ===========
+Private Function CheckNumerList(target As Word.Document) As Long
+  CSE_ProgressBar.Header = "Íóìåðîâàííûå ñïèñêè..."
+  Call CSE_ProgressBar.InitSecondBar(0, target.ListParagraphs.Count)
+  
+  Dim para As Word.Paragraph
+  For Each para In target.ListParagraphs
+    Dim theRange As Word.Range: Set theRange = para.Range
+    If Not theRange.ListFormat.ListString Like "*#*" Or IsHeader(theRange) Then _
+      GoTo NEXT_PARA
+
+    Dim theLvl&: theLvl = theRange.ListFormat.ListLevelNumber
+    If InStr(theRange, Chr(7)) Then _
+      GoTo NEXT_PARA
+    
+    Dim prevRange As Word.Range: Set prevRange = theRange.Previous(wdParagraph)
+    If CheckPrevRangeList(prevRange, theLvl) Then _
+      GoTo NEXT_PARA
+      
+    If theRange.ListFormat.ListValue <> 1 Then
+      Call theRange.Collapse(wdCollapseStart)
+      Call theRange.Comments.Add(theRange, DANG_LISTNUM)
+      CheckNumerList = CheckNumerList + 1
+    End If
+
+NEXT_PARA:
+    Call CSE_ProgressBar.IncrementB
+  Next para
+
+  Call CSE_ProgressBar.HideSecondBar
+  Call CSE_ProgressBar.IncrementA
+End Function
+
+Private Function CheckPrevRangeList(prevRange As Word.Range, theLvl&) As Boolean
+  CheckPrevRangeList = False
+  
+  If prevRange Is Nothing Then _
+    Exit Function
+  If IsHeader(prevRange) Or prevRange.ListFormat.List Is Nothing Then _
+    Exit Function
+
+  CheckPrevRangeList = theLvl <= prevRange.ListFormat.ListLevelNumber
+End Function
+
+Private Function CheckHeaders(target As Word.Document) As Long
+  CSE_ProgressBar.Header = "Ïîèñê áåãàþùèõ çàãîëîâêîâ..."
+  Call CSE_ProgressBar.InitSecondBar(0, target.Range.End)
+  
+  Dim parRng As Word.Range: Set parRng = target.Paragraphs.First.Range
+  Do While Not parRng Is Nothing
+    If Not IsHeader(parRng) Or IsHeader(parRng, 1) Then _
+      GoTo NEXT_PAR
+        
+    If IsFirstInColumn(parRng) Then
+      If parRng.ParagraphFormat.SpaceBefore <> 0 Then
+        Call parRng.Comments.Add(parRng, RUN_HEADER_RUN)
+        CheckHeaders = CheckHeaders + 1
+      End If
+    ElseIf parRng.ParagraphFormat.SpaceBefore <> 0 Then
+      GoTo NEXT_PAR
+    ElseIf Not IsHeader(parRng.Previous(wdParagraph)) Then
+      Call parRng.Comments.Add(parRng, RUN_HEADER_RUN)
+      CheckHeaders = CheckHeaders + 1
+    End If
+NEXT_PAR:
+    Call CSE_ProgressBar.SetB(parRng.End)
+    Set parRng = parRng.Next(wdParagraph, 1)
+  Loop
+  
+  Call CSE_ProgressBar.HideSecondBar
+  Call CSE_ProgressBar.IncrementA
+End Function
+
+Private Function CheckSpaces(target As Word.Document) As Long
+  CSE_ProgressBar.Header = "Ïðîâåðêà îòñòóïîâ..."
+  Call CSE_ProgressBar.InitSecondBar(0, target.Range.End)
+  
+  Dim parRng As Word.Range: Set parRng = target.Paragraphs.First.Range
+  Do While Not parRng Is Nothing
+    If Not IsHeader(parRng) Or IsHeader(parRng, 1) Then _
+      GoTo NEXT_PAR
+    If IsFirstInColumn(parRng) Then _
+      GoTo NEXT_PAR
+    
+    Dim tmpRng As Word.Range: Set tmpRng = parRng.Previous(wdParagraph)
+    'çàãîë âïðèòûê ê ïðåä
+    If IsHeader(tmpRng) And tmpRng.ParagraphFormat.SpaceAfter = 0 Then
+      Call parRng.Comments.Add(parRng, DANG_SPACES)
+      CheckSpaces = CheckSpaces + 1
+    End If
+    
+    'ïåðåä çàãîë ?ðàìêà?
+    If Not IsHeader(tmpRng) And tmpRng.ParagraphFormat.SpaceAfter <> 0 Then
+      If tmpRng.ListFormat.List Is Nothing Then
+        Call parRng.Comments.Add(parRng, DANG_SPACES)
+        CheckSpaces = CheckSpaces + 1
+      End If
+    End If
+    
+    ' ïîñëå çàãîë ?ðàìêà?
+    Set tmpRng = parRng.Next(wdParagraph)
+    If tmpRng.ParagraphFormat.SpaceBefore <> 0 Then
+      Call parRng.Comments.Add(parRng, DANG_SPACES)
+      CheckSpaces = CheckSpaces + 1
+    End If
+NEXT_PAR:
+    Call CSE_ProgressBar.SetB(parRng.End)
+    Set parRng = parRng.Next(wdParagraph, 1)
+  Loop
+  
+  Call CSE_ProgressBar.HideSecondBar
+  Call CSE_ProgressBar.IncrementA
+End Function
+
+Private Function CheckPict(target As Word.Document) As Long
+  CSE_ProgressBar.Header = "Ïîèñê îïàñíûõ ïèêòîãðàìì..."
+  Call CSE_ProgressBar.InitSecondBar(0, target.Shapes.Count)
+  
+  Dim aShape As Word.Shape
+  For Each aShape In target.Shapes
+    If aShape.Type = msoTextBox Then
+      If GetColumn(aShape.Anchor) = T_COL_RIGHT And IsFirstInColumn(aShape.Anchor) Then
+        Call aShape.Anchor.Comments.Add(aShape.Anchor, DANG_PICT)
+        CheckPict = CheckPict + 1
+      End If
+    End If
+    Call CSE_ProgressBar.IncrementB
+  Next aShape
+  
+  Call CSE_ProgressBar.HideSecondBar
+  Call CSE_ProgressBar.IncrementA
+End Function
+
+Private Function CheckDashes(target As Word.Document) As Long
+  CSE_ProgressBar.Header = "Ïðîâåðêà ïîëîæåíèÿ äåôèñîâ..."
+  Call CSE_ProgressBar.InitSecondBar(0, 3)
+  
+  Dim rFind As Word.Range: Set rFind = target.Range.Duplicate
+  Dim tempRange As Word.Range
+  With rFind.Find
+    .Text = Chr(45)
+    Do While .Execute
+      Set tempRange = rFind.Duplicate
+      Call tempRange.Collapse(wdCollapseStart)
+      Call tempRange.Select
+      If PointsToCentimeters(Selection.Information(wdHorizontalPositionRelativeToTextBoundary)) < 0.1 And _
+        rFind.Comments.Count = 0 And rFind.Hyperlinks.Count = 0 And Not IsHeader(rFind) Then
+        Call rFind.Comments.Add(rFind, DANG_DASH)
+        CheckDashes = CheckDashes + 1
+        GoTo skp1
+      End If
+      
+      Set tempRange = rFind.Duplicate
+      Call tempRange.Collapse(wdCollapseEnd)
+      Call tempRange.Select
+      If (PointsToCentimeters(Selection.Information(wdHorizontalPositionRelativeToTextBoundary)) < 0.1 Or _
+          PointsToCentimeters(Selection.Information(wdHorizontalPositionRelativeToTextBoundary)) > 7.4) And _
+          rFind.Comments.Count = 0 And rFind.Hyperlinks.Count = 0 And Not IsHeader(rFind) Then
+        Call rFind.Comments.Add(rFind, DANG_DASH)
+        CheckDashes = CheckDashes + 1
+      End If
+skp1:
+    Loop
+  End With
+  Call CSE_ProgressBar.IncrementB
+  
+  Set rFind = target.Range.Duplicate
+  With rFind.Find
+    .Text = Chr(150)
+    Do While .Execute
+      Set tempRange = rFind.Duplicate
+      Call tempRange.Collapse(wdCollapseStart)
+      Call tempRange.Select
+      If PointsToCentimeters(Selection.Information(wdHorizontalPositionRelativeToTextBoundary)) < 0.1 And _
+          rFind.Comments.Count = 0 And rFind.Hyperlinks.Count = 0 And Not IsHeader(rFind) Then
+        Call rFind.Comments.Add(rFind, DANG_DASH)
+        CheckDashes = CheckDashes + 1
+        GoTo skp2
+      End If
+      
+      Set tempRange = rFind.Duplicate
+      Call tempRange.Collapse(wdCollapseEnd)
+      Call tempRange.Select
+      If (PointsToCentimeters(Selection.Information(wdHorizontalPositionRelativeToTextBoundary)) < 0.1 Or _
+          PointsToCentimeters(Selection.Information(wdHorizontalPositionRelativeToTextBoundary)) > 7.4) And _
+          rFind.Comments.Count = 0 And rFind.Hyperlinks.Count = 0 And Not IsHeader(rFind) Then
+        Call rFind.Comments.Add(rFind, DANG_DASH)
+        CheckDashes = CheckDashes + 1
+      End If
+skp2:
+    Loop
+  End With
+  Call CSE_ProgressBar.IncrementB
+  
+  Set rFind = target.Range.Duplicate
+  With rFind.Find
+    .Text = Chr(151)
+    Do While .Execute
+      Set tempRange = rFind.Duplicate
+      Call tempRange.Collapse(wdCollapseStart)
+      Call tempRange.Select
+      If PointsToCentimeters(Selection.Information(wdHorizontalPositionRelativeToTextBoundary)) < 0.1 And _
+          rFind.Comments.Count = 0 And rFind.Hyperlinks.Count = 0 And Not IsHeader(rFind) Then
+        Call rFind.Comments.Add(rFind, DANG_DASH)
+        CheckDashes = CheckDashes + 1
+        GoTo skp3
+      End If
+      
+      Set tempRange = rFind.Duplicate
+      Call tempRange.Collapse(wdCollapseEnd)
+      Call tempRange.Select
+      If (PointsToCentimeters(Selection.Information(wdHorizontalPositionRelativeToTextBoundary)) < 0.1 Or _
+          PointsToCentimeters(Selection.Information(wdHorizontalPositionRelativeToTextBoundary)) > 7.4) And _
+          rFind.Comments.Count = 0 And rFind.Hyperlinks.Count = 0 And Not IsHeader(rFind) Then
+        Call rFind.Comments.Add(rFind, DANG_DASH)
+        CheckDashes = CheckDashes + 1
+      End If
+skp3:
+    Loop
+  End With
+  Call CSE_ProgressBar.IncrementB
+  Call CSE_ProgressBar.HideSecondBar
+  Call CSE_ProgressBar.IncrementA
+End Function
+
+Private Function CheckFields(target As Word.Document) As Long
+  Dim tmp As Boolean: tmp = target.TrackRevisions
+  target.TrackRevisions = False
+  
+  CSE_ProgressBar.Header = "Ïîèñê íåðàáî÷èõ ïîëåé..."
+  Call CSE_ProgressBar.InitSecondBar(0, target.Fields.Count)
+
+  Dim aField As Word.Field
+  For Each aField In target.Fields
+    If aField.Update = False Then
+      If aField.result.Font.Hidden = False Then
+        CheckFields = CheckFields + 1
+        Call aField.result.Comments.Add(aField.result, DANG_FLD)
+      End If
+    End If
+    Call CSE_ProgressBar.IncrementB
+  Next aField
+  
+  Call CSE_ProgressBar.HideSecondBar
+  Call CSE_ProgressBar.IncrementA
+  
+  target.TrackRevisions = tmp
+End Function

src/CD_AutoDesign.bas

@@ -0,0 +1,691 @@
+Attribute VB_Name = "CD_AutoDesign"
+Option Private Module
+Option Explicit
+
+Private Const HEADS_UNQ_PREF = " _MKT_DLT_HEAD_"
+Private Const LISTS_STARTS = " _MKT_DLT_LIST_"
+
+Private Const TABLE_WIDTH_LIMIT As Double = 8
+Private Const TABLE_HEADER_STYLE = "Íàçâàíèå òàáëèöû"
+
+Private Const STYLE_CONTRACT = "ß_Òèòóë Çàêàç÷èêè"
+Private Const STYLE_THEME = "ß_Òèòóë Îò÷åò î âûïîëíåíèè ðàáîò"
+Private Const STYLE_REQUIREMENTS = "ß_Òèòóë Ëèñò Ñîîòâåòñòâèÿ"
+
+Public Function RunAutoDesign(prefs As AutoDesignOptions)
+  Dim source As Word.Document:  Set source = ActiveDocument
+
+  Call CSE_ProgressBar.Init("Ïåðåâîä â ìàêåò", maxVal:=11 + prefs.Count)
+  Call CSE_ProgressBar.ShowModeless
+  
+  Dim proxyCount&: proxyCount = ADS_PrepareSource(source)
+  Dim target As Word.Document: Set target = ADS_CreateTarget
+  
+  Dim chapters As Collection:  Set chapters = ADS_GenerateSections(target, source)
+  Dim listStyles As Collection:  Set listStyles = ADS_FillSections(target, source, chapters)
+  
+  Call ADS_SetPageSettings(target)
+  
+  If prefs.fixObjects Then _
+    Call ADS_TablesAndInlines(target)
+  If prefs.reapplyLists Then _
+    Call ADS_ReapplyStyles(target, listStyles)
+  
+  Call ADS_FormatHeaders(target, source, proxyCount)
+  
+  If prefs.titlePage Then _
+    Call ADS_TitlePage(target, source)
+  If prefs.generateColontitles Then _
+    Call ADS_Colontitles(target)
+
+  If prefs.doLayout Then _
+    Call ADS_TextLayout(target)
+    
+  Call ADS_UpdateToc(target)
+  Call ADS_Paint(target)
+  
+  Call ADS_Finalize(target)
+
+  Unload CSE_ProgressBar
+End Function
+
+' ==============
+Private Function ADS_UpdateToc(target As Word.Document)
+  CSE_ProgressBar.Header = "Ôîðìèðîâàíèå îãëàâëåíèÿ..."
+  Dim toc As Word.TableOfContents
+  For Each toc In target.TablesOfContents
+    Call UpdateTableOfContents(toc)
+  Next toc
+  Call CSE_ProgressBar.IncrementA
+End Function
+
+Private Function ADS_Paint(target As Word.Document)
+  Call RepaintText(target)
+  Call CSE_ProgressBar.IncrementA
+  
+  Call RepaintTextShapes(target)
+  Call CSE_ProgressBar.IncrementA
+  
+  Call RepaintToC(target)
+  Call CSE_ProgressBar.IncrementA
+  
+  Call RepaintHLinks(target)
+  Call CSE_ProgressBar.IncrementA
+End Function
+
+Private Function ADS_PrepareSource(source As Word.Document) As Long
+  CSE_ProgressBar.Header = "Ïîäãîòîâêà èñõîäíîãî äîêóìåíòà..."
+  ADS_PrepareSource = MarkListItems(source)
+  Call MarkListsBegin(source)
+  Call CSE_ProgressBar.IncrementA
+End Function
+
+Private Function ADS_CreateTarget() As Word.Document
+  CSE_ProgressBar.Header = "Ñîçäàíèå äîêóìåíòà..."
+  
+  Dim wrapper As New API_WordWrapper
+  Dim target As Word.Document: Set target = wrapper.NewDocument("20 Ìàêåò", False)
+  target.AttachedTemplate = ""
+  target.UpdateStylesOnOpen = False
+  
+  Call RemoveSampleSections(target)
+  
+  Set ADS_CreateTarget = target
+  Call CSE_ProgressBar.IncrementA
+End Function
+
+Private Function ADS_GenerateSections(target As Word.Document, source As Word.Document) As Collection
+  CSE_ProgressBar.Header = "Ñîçäàíèå ãëàâ..."
+  Dim chapters As Collection: Set chapters = ScanChaptersInfo(source)
+  Dim intro As Word.Range: Set intro = target.Range(target.Sections(4).Range.Start, target.Sections(6).Range.End)
+  Call CopyPasteRepeat(intro, target.Sections(7).Range.Start, target, chapters.Count - 1)
+  
+  Call TransferChapterHeaders(chapters, target)
+  
+  Call CSE_ProgressBar.IncrementA
+  Set ADS_GenerateSections = chapters
+End Function
+
+Private Function ADS_FillSections(target As Word.Document, source As Word.Document, chapters As Collection) As Collection
+  CSE_ProgressBar.Header = "Çàïîëíåíèå ðàçäåëîâ..."
+  
+  Dim listStyles As New Collection
+  Dim aStyle As Word.Style
+  For Each aStyle In source.Styles
+    Dim sLocal$: sLocal = aStyle.NameLocal
+    If WordStyleExists(target, sLocal) Then
+      If CheckListStyle(target.Styles(sLocal)) Then
+        Call listStyles.Add(sLocal)
+      End If
+    End If
+  Next aStyle
+  
+  Call TransferChapersBody(chapters, source, target)
+  
+  Call CSE_ProgressBar.IncrementA
+  Set ADS_FillSections = listStyles
+End Function
+
+Private Function ADS_SetPageSettings(target As Word.Document)
+  CSE_ProgressBar.Header = "Ïðîâåðêà ïîëåé ïå÷àòè..."
+  Call CSE_ProgressBar.InitSecondBar(0, target.Sections.Count - 3)
+  Dim i&
+  For i = 3 To target.Sections.Count - 1
+    With target.Sections(i).PageSetup
+      .LeftMargin = CentimetersToPoints(FIELD_SIZE_CM)
+      .RightMargin = CentimetersToPoints(FIELD_SIZE_CM)
+      .TopMargin = CentimetersToPoints(FIELD_SIZE_CM)
+      .BottomMargin = CentimetersToPoints(FIELD_SIZE_CM)
+      
+      .DifferentFirstPageHeaderFooter = False
+      .HeaderDistance = CentimetersToPoints(1.25)
+      .FooterDistance = CentimetersToPoints(1.25)
+      .OddAndEvenPagesHeaderFooter = False
+    End With
+    Call CSE_ProgressBar.IncrementB
+  Next i
+  
+  target.Footnotes.Location = wdBeneathText
+  
+  Call CSE_ProgressBar.IncrementA
+  Call CSE_ProgressBar.HideSecondBar
+End Function
+
+Private Function ADS_TablesAndInlines(target As Word.Document)
+  CSE_ProgressBar.Header = "Îáðàáîòêà âñòàâîê..."
+  Call CSE_ProgressBar.InitSecondBar(0, target.InlineShapes.Count + target.Tables.Count)
+
+  Dim iShp As Word.InlineShape
+  For Each iShp In target.InlineShapes
+    Dim rShape As Word.Range: Set rShape = iShp.Range
+    If rShape.PageSetup.TextColumns.Count > 1 Then
+      If rShape.Paragraphs(1).Next.Range.Style = "Íàçâàíèå îáúåêòà" Then
+        Call rShape.MoveEnd(wdParagraph, 2)
+        Call InsertOneColomnSection(rShape)
+      End If
+    End If
+    
+    Call CSE_ProgressBar.IncrementB
+  Next iShp
+  
+  Dim aTable As Word.Table
+  For Each aTable In target.Tables
+    Dim rTable As Word.Range: Set rTable = aTable.Range
+    aTable.PreferredWidthType = wdPreferredWidthPoints
+    If rTable.PageSetup.TextColumns.Count > 1 And aTable.PreferredWidth >= CentimetersToPoints(TABLE_WIDTH_LIMIT) Then
+      aTable.PreferredWidthType = wdPreferredWidthPercent
+      aTable.PreferredWidth = 100
+      If rTable.Paragraphs(1).Previous.Range.Style = TABLE_HEADER_STYLE Then
+        Call rTable.MoveStart(wdParagraph, -1)
+        Call InsertOneColomnSection(rTable)
+      End If
+    End If
+    
+    Call CSE_ProgressBar.IncrementB
+  Next aTable
+  
+  Call CSE_ProgressBar.IncrementA
+  Call CSE_ProgressBar.HideSecondBar
+End Function
+
+Private Function ADS_ReapplyStyles(target As Word.Document, listStyles As Collection)
+  CSE_ProgressBar.Header = "Ïîâòîðíîå ïðèìåíåíèå ñòèëåé..."
+    
+  Call CSE_ProgressBar.InitSecondBar(0, listStyles.Count)
+  Dim aStyle As Variant
+  For Each aStyle In listStyles
+    Call ReApplyStyle(target, CStr(aStyle))
+    Call CSE_ProgressBar.IncrementB
+  Next aStyle
+  
+  Call CSE_ProgressBar.IncrementA
+  Call CSE_ProgressBar.HideSecondBar
+End Function
+
+Private Function ADS_FormatHeaders(target As Word.Document, source As Word.Document, proxyCount&)
+  CSE_ProgressBar.Header = "Ôîðìàòèðîâàíèå çàãîëîâêîâ..."
+  
+  Call FinalizeLists(source, True)
+  Call FinalizeLists(target, False)
+  
+  Call FixGapsStyle(target)
+  Call TransferHeaderFormats(target, source)
+  
+  Call RemoveListPoxy(source, proxyCount)
+  Call RemoveListPoxy(target, proxyCount)
+  
+  Call CSE_ProgressBar.IncrementA
+End Function
+
+Private Function ADS_TitlePage(target As Word.Document, source As Word.Document)
+  CSE_ProgressBar.Header = "Ïåðåíîñ òèòóëà è ëèñòà ñîîâòåòñòâèÿ..."
+  Call TransferTitlePage(source, target)
+  Call TransferWorkerList(source, target)
+  Call TransferRequirements(source, target)
+  Call CSE_ProgressBar.IncrementA
+End Function
+
+Private Function ADS_TextLayout(target As Word.Document)
+  CSE_ProgressBar.Header = "Âûðàâíèâàíèå..."
+  Call UpdateListsLayout(target)
+  Call UpdateTextLayout(target)
+  Call UpdateObjectFields(target)
+  Call CSE_ProgressBar.IncrementA
+End Function
+
+Private Function ADS_Colontitles(target As Word.Document)
+  CSE_ProgressBar.Header = "Ðàññòàíîâêà êîëîíòèòóëîâ..."
+  
+  Dim docData As New InfoDocument: Call docData.Init(target)
+  Dim iColons As New ItemColontitles
+  With iColons
+    .mTopLeft = T_SOURCE_VOLUME
+    .mTopRight = T_SOURCE_BOOK
+    .mBottomLeft = T_SOURCE_CONCEPT
+    .mBottomRight = T_SOURCE_SECTION
+    .start_ = 3
+    .finish_ = target.Sections.Count - 1
+    
+    .doBottomRight = True
+    .doTopLeft = docData.IsValidNames
+    .doTopRight = .doTopLeft
+  End With
+  
+  Call CSE_ProgressBar.InitSecondBar(0, iColons.finish_ - iColons.start_ + 1)
+  Call CreateColontitles(target, docData, iColons, "IncrementB")
+  Call CSE_ProgressBar.HideSecondBar
+  Call CSE_ProgressBar.IncrementA
+End Function
+
+Private Function ADS_Finalize(target As Word.Document)
+  CSE_ProgressBar.Header = "Ôèíàëèçàöèÿ..."
+  Dim i%
+  For i = 3 To target.Sections.Count - 1
+    With target.Sections(i)
+      Dim iComment As Word.Range: Set iComment = target.Range(.Range.Start, .Range.Start)
+      If .PageSetup.Orientation = wdOrientLandscape Then _
+        Call iComment.Comments.Add(iComment, "Âû óâåðåíû â îðèåíòàöèè?")
+    End With
+  Next i
+  Call CSE_ProgressBar.IncrementA
+End Function
+
+Private Function RemoveSampleSections(target As Word.Document)
+  Do While target.Sections.Count > 7
+    Call target.Sections(target.Sections.Count - 1).Range.Delete
+  Loop
+End Function
+
+Private Function FinalizeLists(target As Word.Document, justClear As Boolean)
+  Dim rFind As Word.Range: Set rFind = target.Range
+  rFind.Find.Text = LISTS_STARTS
+  Do While rFind.Find.Execute
+    Call rFind.MoveEnd(wdCharacter, 4)
+    Dim aTemplate As Word.ListTemplate: Set aTemplate = rFind.ListFormat.ListTemplate
+    aTemplate.ListLevels(1).StartAt = CLng(Right(rFind.Text, 4))
+    If Not justClear Then
+      Call rFind.ListFormat.ApplyListTemplate(ListTemplate:=aTemplate, _
+                                              ContinuePreviousList:=False, _
+                                              ApplyTo:=wdListApplyToWholeList, _
+                                              DefaultListBehavior:=wdWord10ListBehavior)
+    End If
+    rFind.Delete
+  Loop
+End Function
+
+Private Function MarkListsBegin(target As Word.Document)
+  Dim tmpLst As Word.List, tmpLstRange As Word.Range
+  For Each tmpLst In target.Lists
+    If IsHeader(tmpLst.ListParagraphs(1).Range) Then _
+      GoTo CONT_FOR
+    Set tmpLstRange = tmpLst.ListParagraphs(1).Range
+    
+    Call tmpLstRange.MoveEndUntil(Chr(13), wdBackward)
+    Call tmpLstRange.MoveEnd(wdCharacter, -1)
+    
+    If Right(tmpLstRange.ListFormat.ListString, 2) Like "#?" Then
+      Call tmpLstRange.InsertAfter(LISTS_STARTS & Format(tmpLstRange.ListFormat.ListValue, "0000"))
+    End If
+CONT_FOR:
+  Next tmpLst
+End Function
+
+Private Function MarkListItems(target As Word.Document) As Long
+  Dim hdNames As New Collection
+  Dim listItem As Word.Paragraph
+  For Each listItem In target.ListParagraphs
+    Dim tmpRng As Word.Range: Set tmpRng = listItem.Range
+    If Not InCollection(tmpRng.Text, hdNames) Then
+      Call hdNames.Add(tmpRng.Text, tmpRng.Text)
+      GoTo NEXT_ITEM
+    End If
+
+    MarkListItems = MarkListItems + 1
+    Call tmpRng.MoveEnd(wdCharacter, -1)
+    Dim sMark$: sMark = HEADS_UNQ_PREF & CStr(MarkListItems)
+    Call tmpRng.InsertAfter(sMark)
+    Call tmpRng.MoveEnd(wdCharacter, 1)
+NEXT_ITEM:
+  Next listItem
+End Function
+
+Private Function RemoveListPoxy(target As Word.Document, proxyCount&)
+  Dim nProxy&
+  For nProxy = 1 To proxyCount Step 1
+    Dim rFind As Word.Range: Set rFind = target.Range
+    With rFind.Find
+      .ClearFormatting
+      .Text = "<" & Mid(HEADS_UNQ_PREF & nProxy, 3) & ">"
+      .MatchWildcards = True
+      
+      If .Execute Then
+        Call rFind.MoveStart(wdCharacter, -2)
+        rFind.Delete
+      End If
+    End With
+  Next nProxy
+End Function
+
+Private Function CheckListStyle(target As Word.Style) As Boolean
+  CheckListStyle = Not target.NameLocal Like "[Çç]àãîëîâîê*"
+  CheckListStyle = CheckListStyle And _
+    (target.NameLocal Like "*[Ìì]àðê[åè]ð*" Or target.NameLocal Like "*[Íí]óìåð*")
+End Function
+
+Private Function TransferWorkerList(source As Word.Document, dest As Word.Document)
+  source.Sections(3).Range.Tables(1).Range.Copy
+  Dim insertPosition&: insertPosition = dest.Sections(2).Range.Tables(1).Range.Start
+  Call dest.Sections(2).Range.Tables(1).Delete
+  Call dest.Range(insertPosition&, insertPosition&).PasteAndFormat(wdUseDestinationStylesRecovery)
+End Function
+
+Private Function TransferRequirements(source As Word.Document, dest As Word.Document)
+  If RequirementsPosition(source) = 0 Then _
+    Exit Function
+  If RequirementsPosition(dest) = 0 Then _
+    Exit Function
+    
+  Call source.Tables(source.Tables.Count).Range.Copy
+  Call dest.Tables(dest.Tables.Count).Delete
+  Call dest.Paragraphs.Last.Range.Paste
+End Function
+
+Private Function TransferChapterHeaders(chapters As Collection, doc As Word.Document)
+  Call CSE_ProgressBar.InitSecondBar(0, chapters.Count)
+  
+  Dim ColorIndex&: ColorIndex = 0
+  Dim i&, j&: j = 4
+  For i = 1 To chapters.Count
+    Dim headerText$: headerText$ = chapters(i).text_
+    headerText = Left(headerText$, Len(headerText$) - 1)
+    
+    Dim rPaste As Word.Range: Set rPaste = doc.Sections(j).Range.Duplicate
+    Call rPaste.MoveEnd(wdWord, -2)
+    rPaste.Text = headerText$
+    
+    Dim clrID As WdThemeColorIndex
+    Select Case (i - 1 - ColorIndex) Mod 7
+      Case 0 To 4: clrID = (i - 1 - ColorIndex) Mod 7 + 5
+      Case 5: clrID = wdThemeColorBackground2
+      Case 6: clrID = wdThemeColorText2
+    End Select
+    
+    If InStr(UCase(headerText), "ÂÂÅÄÅÍÈÅ") + InStr(UCase(headerText), "ÇÀÊËÞ×ÅÍÈÅ") <> 0 Then
+      clrID = wdThemeColorAccent1
+      ColorIndex = ColorIndex + 1
+    End If
+    rPaste.Paragraphs.First.Range.Font.Color = DesignTheme(clrID)
+    j = j + 3
+    
+    Call CSE_ProgressBar.IncrementB
+  Next i
+  
+  Call CSE_ProgressBar.HideSecondBar
+End Function
+
+Private Function ReApplyStyle(target As Word.Document, aStyle$)
+  If Not WordStyleExists(target, aStyle) Then _
+    Exit Function
+  
+  Dim rFind As Word.Range: Set rFind = target.Range
+  Dim lastEnd&
+  rFind.Find.Style = target.Styles(aStyle)
+  Do While rFind.Find.Execute
+    Dim resetRange As Word.Range: Set resetRange = rFind.Duplicate
+    resetRange.Start = IIf(Len(rFind) < 2, rFind.Start, rFind.End - 1)
+    resetRange.End = IIf(Len(rFind) < 2, rFind.End, rFind.End - 1)
+    resetRange.Style = target.Styles(aStyle)
+    
+    Call rFind.Collapse(wdCollapseEnd)
+    If rFind.Start >= target.Range.End - 1 Then _
+      Exit Function
+    If rFind.Start = lastEnd Then _
+      Call rFind.Move(wdCharacter, 1)
+    
+    lastEnd = rFind.End
+  Loop
+End Function
+
+Private Function ScanChaptersInfo(target As Word.Document) As Collection
+  Dim result As New Collection
+  Dim para As Word.Paragraph
+  For Each para In target.Paragraphs
+    If IsHeader(para.Range, 1) Then
+      Dim info As New ItemChapter
+      info.start_ = para.Range.Start
+      info.finish_ = para.Range.End
+      
+      Dim lstStrng$: lstStrng = ""
+      If para.Range.ListParagraphs.Count <> 0 Then _
+        lstStrng = para.Range.ListFormat.ListString
+      
+      info.text_ = lstStrng & _
+            IIf(Left(para.Range, 1) = " ", "", _
+              IIf(lstStrng = "", "", " ")) & para.Range
+      Call result.Add(info.Clone)
+    End If
+  Next para
+  Set ScanChaptersInfo = result
+End Function
+
+Private Function TransferChapersBody(chapters As Collection, source As Word.Document, dest As Word.Document)
+  Call CSE_ProgressBar.InitSecondBar(0, chapters.Count)
+  
+  Dim aChapter As ItemChapter: Set aChapter = chapters(chapters.Count)
+  Dim lastFinish&: lastFinish = RequirementsPosition(source)
+  If aChapter.finish_ <= lastFinish Then
+    Call source.Range(aChapter.finish_, lastFinish).Copy
+    Call dest.Range(dest.Sections(chapters.Count * 3 + 2).Range.Start, dest.Sections(chapters.Count * 3 + 2).Range.Start).Paste
+  End If
+  Call CSE_ProgressBar.IncrementB
+  
+  Dim i&
+  For i = chapters.Count - 1 To 1 Step -1
+    If chapters(i).finish_ <> chapters(i + 1).start_ Then
+      Call source.Range(chapters(i).finish_, chapters(i + 1).start_).Copy
+      Call dest.Range(dest.Sections(i * 3 + 2).Range.Start, dest.Sections(i * 3 + 2).Range.Start).Paste
+    End If
+    Call CSE_ProgressBar.IncrementB
+  Next i
+  
+  Call CSE_ProgressBar.HideSecondBar
+End Function
+
+Private Function TransferHeaderFormats(target As Word.Document, source As Word.Document)
+  Call CSE_ProgressBar.InitSecondBar(0, target.ListParagraphs.Count)
+  
+  Dim listPrefixes As New Collection: Set listPrefixes = ExtractListPrefixes(source)
+  
+  Dim pCurrent As Word.Paragraph
+  For Each pCurrent In target.ListParagraphs
+    Dim rCurrent As Word.Range: Set rCurrent = pCurrent.Range
+    If rCurrent.ParagraphFormat.OutlineLevel <> wdOutlineLevelBodyText Then
+      Dim sPrefix$: sPrefix = listPrefixes(rCurrent.Text)
+      Dim sHeaderText$: sHeaderText = RemoveListPrefix(rCurrent.Text)
+      Call InsertHeader(rCurrent, sPrefix & " " & sHeaderText, rCurrent.ListFormat.ListLevelNumber)
+    End If
+    
+    Call CSE_ProgressBar.IncrementB
+  Next pCurrent
+  
+  For Each pCurrent In target.ListParagraphs
+    If pCurrent.Range.ParagraphFormat.OutlineLevel <> wdOutlineLevelBodyText Then _
+      Call pCurrent.Range.Delete
+  Next pCurrent
+  
+  Call CSE_ProgressBar.HideSecondBar
+End Function
+
+Private Function TransferTitlePage(source As Word.Document, target As Word.Document)
+  Dim titleData As TitlePageData: titleData = ExtractTitlePageData(source)
+
+  Call TransferBook(target, titleData)
+  Call TransferVolume(target, titleData)
+  
+  If Not titleData.rContract Is Nothing Then _
+    Call TransferContract(target, titleData.rContract)
+  If Not titleData.rCustomer Is Nothing Then _
+    Call TransferCustomer(target, titleData.rCustomer)
+  If Not titleData.rTheme Is Nothing Then _
+    Call TransferTheme(target, titleData.rTheme)
+End Function
+
+Private Function CopyPasteRepeat(target As Word.Range, nPos&, doc As Word.Document, nCount&)
+  Call target.Copy
+  Dim i&
+  For i = 1 To nCount
+    Call doc.Range(nPos, nPos).PasteAndFormat(wdFormatOriginalFormatting)
+  Next i
+End Function
+
+Private Function ExtractListPrefixes(target As Word.Document) As Collection
+  Dim result As New Collection
+  Dim listItem As Word.Paragraph
+  For Each listItem In target.ListParagraphs
+    If listItem.Range.ParagraphFormat.OutlineLevel <> wdOutlineLevelBodyText Then
+      Call result.Add(listItem.Range.ListFormat.ListString, listItem.Range.Text)
+    End If
+  Next listItem
+  Set ExtractListPrefixes = result
+End Function
+
+Private Function RemoveListPrefix(listText$) As String
+  Dim result$: result = listText
+  Do While Asc(Right(result, 1)) <= 32
+    result = Left(result, Len(result) - 1)
+  Loop
+  RemoveListPrefix = result
+End Function
+
+Private Function RequirementsPosition(target As Word.Document) As Long
+  RequirementsPosition = target.Range.End
+  Dim rFind As Word.Range: Set rFind = target.Range
+  With rFind.Find
+    .Text = "Ëèñò ñîîòâåòñòâèÿ"
+    .Style = STYLE_REQUIREMENTS
+    If Not .Execute Then _
+      Exit Function
+  End With
+  RequirementsPosition = rFind.Start
+End Function
+
+Private Function ExtractTitlePageData(target As Word.Document) As TitlePageData
+  Dim result As TitlePageData
+  
+  Dim rFind As Word.Range
+  Set rFind = target.Sections(2).Range
+  rFind.Find.Text = "Êíèãà "
+  rFind.Find.MatchCase = False
+  If rFind.Find.Execute Then
+    Set rFind = rFind.Next(wdWord, 1)
+    result.nBookID = CLng(rFind.Text)
+    
+    Call rFind.MoveEndUntil(CSET_SLETTERS & CSET_BLETTERS, wdForward)
+    Call rFind.Collapse(wdCollapseEnd)
+    Call rFind.MoveEndUntil(Chr(13), wdForward)
+    result.sBook = rFind.Text
+  End If
+  
+  Set rFind = target.Sections(2).Range
+  rFind.Find.Text = "Òîì "
+  rFind.Find.MatchCase = False
+  If rFind.Find.Execute Then
+    Set rFind = rFind.Next(wdWord, 1)
+    result.nVolumeID = CLng(rFind.Text)
+    
+    Call rFind.MoveEndUntil(CSET_SLETTERS & CSET_BLETTERS, wdForward)
+    Call rFind.Collapse(wdCollapseEnd)
+    Call rFind.MoveEndUntil(Chr(13))
+    result.sVolume = rFind.Text
+  End If
+  
+  Set rFind = target.Sections(2).Range
+  rFind.Find.Text = "Äîãîâîð "
+  rFind.Find.Style = STYLE_CONTRACT
+  rFind.Find.Format = True
+  If rFind.Find.Execute Then
+    Set result.rContract = rFind.Paragraphs.First.Range.Duplicate
+  End If
+  
+  Set rFind = target.Sections(2).Range
+  rFind.Find.Text = "Çàêàç÷èê: "
+  rFind.Find.Style = STYLE_CONTRACT
+  rFind.Find.Format = True
+  If rFind.Find.Execute Then
+    Set result.rCustomer = rFind.Paragraphs.First.Range.Duplicate
+  End If
+
+  Set rFind = target.Sections(2).Range
+  rFind.Find.Style = STYLE_THEME
+  rFind.Find.Format = True
+  If rFind.Find.Execute Then
+    Set result.rTheme = rFind.Paragraphs.First.Range.Duplicate
+  End If
+  
+  ExtractTitlePageData = result
+End Function
+
+Private Function TransferBook(target As Word.Document, titleData As TitlePageData)
+  Dim rPaste As Word.Range: Set rPaste = target.Sections(1).Range
+  With rPaste.Find
+    .Text = "Êíèãà "
+    .Format = True
+    .MatchCase = False
+  End With
+  
+  If Not rPaste.Find.Execute Then _
+    Exit Function
+  Set rPaste = rPaste.Next(wdWord, 1)
+  If titleData.nBookID <> 0 Then _
+    rPaste.Text = titleData.nBookID
+    
+  If titleData.sBook = "" Then _
+    Exit Function
+  Call rPaste.MoveEndUntil(CSET_SLETTERS & CSET_BLETTERS, wdForward)
+  Call rPaste.Collapse(wdCollapseEnd)
+  Call rPaste.MoveEndUntil(Chr(13), wdForward)
+  rPaste.Text = titleData.sBook
+End Function
+
+Private Function TransferVolume(target As Word.Document, titleData As TitlePageData)
+  Dim rPaste As Word.Range: Set rPaste = target.Sections(1).Range
+  With rPaste.Find
+    .Text = "Òîì "
+    .Format = True
+    .MatchCase = False
+  End With
+  If Not rPaste.Find.Execute Then _
+    Exit Function
+    
+  Set rPaste = rPaste.Next(wdWord, 1)
+  If titleData.nVolumeID <> 0 Then _
+    rPaste.Text = titleData.nVolumeID
+    
+  If titleData.sVolume = "" Then _
+    Exit Function
+  Call rPaste.MoveEndUntil(CSET_SLETTERS & CSET_BLETTERS, wdForward)
+  Call rPaste.Collapse(wdCollapseEnd)
+  Call rPaste.MoveEndUntil(Chr(13), wdForward)
+  rPaste.Text = titleData.sVolume
+End Function
+
+Private Function TransferContract(target As Word.Document, rContract As Word.Range)
+  Dim rPaste As Word.Range: Set rPaste = target.Sections(1).Range
+  With rPaste.Find
+    .Text = "Äîãîâîð "
+    .Format = True
+    .Style = STYLE_CONTRACT
+  End With
+  If Not rPaste.Find.Execute Then _
+    Exit Function
+  
+  Call rContract.Copy
+  Call rPaste.Paragraphs.First.Range.PasteAndFormat(wdUseDestinationStylesRecovery)
+End Function
+
+Private Function TransferCustomer(target As Word.Document, rCustomer As Word.Range)
+  Dim rPaste As Word.Range: Set rPaste = target.Sections(1).Range
+  With rPaste.Find
+    .Text = "Äîãîâîð "
+    .Format = True
+    .Style = STYLE_CONTRACT
+  End With
+  If Not rPaste.Find.Execute Then _
+    Exit Function
+  
+  Call rCustomer.Copy
+  Call rPaste.Paragraphs.First.Range.PasteAndFormat(wdUseDestinationStylesRecovery)
+End Function
+
+Private Function TransferTheme(target As Word.Document, rTheme As Word.Range)
+  Dim rPaste As Word.Range: Set rPaste = target.Sections(1).Range
+  With rPaste.Find
+    .Format = True
+    .Style = STYLE_THEME
+  End With
+  If Not rPaste.Find.Execute Then _
+    Exit Function
+  
+  Call rTheme.Copy
+  Call rPaste.Paragraphs.First.Range.PasteAndFormat(wdUseDestinationStylesRecovery)
+End Function

src/CD_Colontitles.bas

@@ -0,0 +1,270 @@
+Attribute VB_Name = "CD_Colontitles"
+Option Private Module
+Option Explicit
+
+Public Function CreateColontitles(target As Word.Document, docMeta As InfoDocument, _
+                                  props As ItemColontitles, incrementCallback$)
+  Dim sPrevious$
+  Dim nCurrent&: nCurrent = props.start_
+  Do While nCurrent <= props.finish_
+    Dim aSection As Word.Section: Set aSection = target.Sections(nCurrent)
+    Dim headRange As Word.Range: Set headRange = aSection.Range.Paragraphs.First.Range
+    If Not (IsHeader(headRange, 1) Or IsToCHeader(headRange)) Or VBA.Len(headRange.Text) <= 3 Then
+      Call ResetSection(aSection)
+      GoTo NEXT_SECTION
+    End If
+    
+   Call ProcessSection(aSection, docMeta, props, sPrevious, nCurrent = props.start_)
+    
+NEXT_SECTION:
+    nCurrent = nCurrent + 1
+    Call CallByName(CSE_ProgressBar, incrementCallback, VbMethod)
+  Loop
+End Function
+
+' ============
+Private Function ResetSection(aSection As Word.Section)
+  aSection.PageSetup.DifferentFirstPageHeaderFooter = False
+  aSection.PageSetup.OddAndEvenPagesHeaderFooter = True
+  aSection.Headers(wdHeaderFooterPrimary).LinkToPrevious = True
+  aSection.Headers(wdHeaderFooterEvenPages).LinkToPrevious = True
+  aSection.Footers(wdHeaderFooterPrimary).LinkToPrevious = True
+  aSection.Footers(wdHeaderFooterEvenPages).LinkToPrevious = True
+End Function
+
+Private Function ScanSection(target As Word.Section, ByRef sPrevious$) As SectionData
+  Dim aData As SectionData
+  
+  Dim headRange As Word.Range: Set headRange = target.Range.Paragraphs.First.Range
+  If headRange.Style = "Çàãîëîâîê Ãëàâû" Then
+    Call headRange.MoveEnd(wdWord, -1)
+    aData.sChapter = headRange.Text
+  Else
+    aData.sName = headRange.Text
+    If IsUsualSecName(aData.sName, headRange) Then _
+      aData.sName = "Ðàçäåë " & aData.sName
+    If IsToCHeader(aData.sName) Then _
+      aData.sChapter = aData.sName
+  End If
+  
+  aData.bNewChapter = aData.sChapter = sPrevious And Not sPrevious = ""
+  sPrevious = aData.sChapter
+  ScanSection = aData
+End Function
+
+Private Function ProcessSection(target As Word.Section, docMeta As InfoDocument, props As ItemColontitles, ByRef sPrevious$, bFrist As Boolean)
+  Dim sData As SectionData: sData = ScanSection(target, sPrevious)
+  Dim cPos As ColontitlePosition
+  
+  If props.doTopLeft Then
+    cPos.top_ = True
+    cPos.left_ = True
+    cPos.source_ = props.mTopLeft
+    Call ProcessTitle(target, docMeta, cPos, sData, Not bFrist And DoLink(cPos.source_, sData.bNewChapter))
+  End If
+  
+  If props.doTopRight Then
+    cPos.top_ = True
+    cPos.left_ = False
+    cPos.source_ = props.mTopRight
+    Call ProcessTitle(target, docMeta, cPos, sData, Not bFrist And DoLink(cPos.source_, sData.bNewChapter))
+  End If
+  
+  If props.doBottomLeft Then
+    cPos.top_ = False
+    cPos.left_ = True
+    cPos.source_ = props.mBottomLeft
+    Call ProcessTitle(target, docMeta, cPos, sData, Not bFrist And DoLink(cPos.source_, sData.bNewChapter))
+  End If
+  
+  If props.doBottomRight Then
+    cPos.top_ = False
+    cPos.left_ = False
+    cPos.source_ = props.mBottomRight
+    Call ProcessTitle(target, docMeta, cPos, sData, Not bFrist And DoLink(cPos.source_, sData.bNewChapter))
+  End If
+End Function
+
+Private Function ProcessTitle(target As Word.Section, docMeta As InfoDocument, cPos As ColontitlePosition, sData As SectionData, linkToPrev As Boolean)
+  Dim oTitle As Word.HeaderFooter: Set oTitle = GetHeader(target, cPos)
+  oTitle.LinkToPrevious = linkToPrev
+  If linkToPrev Then _
+    Exit Function
+
+  Call ReplaceColontitle(oTitle, cPos, TitlesText(cPos.source_, sData, docMeta))
+End Function
+
+Private Function TitlesText(sMode As TSource, sData As SectionData, docMeta As InfoDocument) As String
+  Select Case sMode:
+  Case T_SOURCE_BOOK: TitlesText = docMeta.BookText
+  Case T_SOURCE_VOLUME: TitlesText = docMeta.VolumeText
+  Case T_SOURCE_DOCUMENT: TitlesText = docMeta.document_
+  Case T_SOURCE_SECTION: TitlesText = sData.sName
+  Case T_SOURCE_CHAPTER:  TitlesText = sData.sChapter
+  Case T_SOURCE_CONCEPT:
+    TitlesText = "Öåíòð èííîâàöèé è âûñîêèõ òåõíîëîãèé ""ÊÎÍÖÅÏÒ""" & ", " & CStr(Year(Date))
+  End Select
+End Function
+
+Private Function ReplaceColontitle(target As Word.HeaderFooter, cPos As ColontitlePosition, sText$)
+  If cPos.top_ Then
+    Call InsertHeader(target.Range, sText, cPos)
+    If cPos.source_ <> T_SOURCE_DOCUMENT And cPos.source_ <> T_SOURCE_CONCEPT Then _
+      Call BoldHeaderPart(target.Range)
+    Call HeadersWrap(target.Range)
+  Else
+    If cPos.source_ = T_SOURCE_SECTION And InStr(UCase(sText), UCase("Ïðèëîæåíèå")) = 0 Then _
+      sText = Mid(sText, InStr(sText, ".") + 1)
+    Call InsertFooter(target.Range, sText, cPos)
+  End If
+End Function
+
+Private Function BoldHeaderPart(target As Word.Range)
+  target.Bold = False
+  Dim boldPart As Word.Range:  Set boldPart = target.Words.First
+  If boldPart.MoveEndUntil(".", wdForward) Then
+    boldPart.End = boldPart.End + 1
+    boldPart.Bold = True
+  End If
+End Function
+
+Private Function InsertHeader(target As Word.Range, sText$, cPos As ColontitlePosition)
+  target.Text = sText
+  target.Style = "Âåðõíèé êîëîíòèòóë"
+  Call target.Words.Last.Delete
+End Function
+
+Private Function InsertFooter(target As Word.Range, sText$, cPos As ColontitlePosition)
+  Call CleanFooter(target, cPos)
+  
+  If Len(sText) >= 2 Then
+    If Asc(Left(sText, 1)) < 33 Then sText = Mid(sText, 2)
+    If Asc(Right(sText, 1)) < 33 Then sText = Left(sText, Len(sText) - 1)
+  End If
+  
+  Call target.InsertBefore(UCase(sText))
+  If cPos.left_ Then
+    Call FormatLeftFooter(target)
+  Else
+    Call FormatRightFooter(target)
+  End If
+End Function
+
+Private Function FormatRightFooter(target As Word.Range)
+  Dim rDest As Word.Range: Set rDest = target.Duplicate
+  Call rDest.MoveEnd(wdWord, -2)
+  
+  If Len(rDest.Text) < 30 Then
+    Call rDest.InsertBefore(Chr(11))
+  Else
+    Dim rSecondLine As Word.Range: Set rSecondLine = rDest.Duplicate
+    Call rSecondLine.Collapse(wdCollapseEnd)
+    Do
+      Call rDest.MoveEnd(wdWord, -1)
+      Call rSecondLine.MoveStart(wdWord, -1)
+    Loop Until Len(rDest.Text) + 2 < Len(rSecondLine.Text)
+    
+    Call rSecondLine.InsertBefore(Chr(11))
+    Call target.Words.Last.Delete
+  End If
+End Function
+
+Private Function FormatLeftFooter(target As Word.Range)
+  Dim rDest As Word.Range: Set rDest = target.Duplicate
+  Call rDest.MoveEnd(wdWord, IIf(rDest.Fields.Count = 1, -2, -1))
+  
+  Dim oldText$
+  If Len(rDest.Text) < 30 Then
+    oldText = rDest.Text
+    Call rDest.Delete
+    
+    Call target.InsertBefore(Chr(11))
+    
+    Call target.InsertAfter(Chr(9))
+    Call target.InsertAfter(oldText)
+    Call target.InsertBefore(Chr(9))
+    rDest.End = target.End
+    rDest.Start = rDest.End
+    Call rDest.MoveStart(wdWord, -1)
+    Call rDest.Delete
+  Else
+    Dim rSecondLine As Word.Range: Set rSecondLine = rDest.Duplicate
+    Call rSecondLine.Collapse(wdCollapseEnd)
+    Do
+      Call rDest.MoveEnd(wdWord, -1)
+      Call rSecondLine.MoveStart(wdWord, -1)
+    Loop Until Len(rDest.Text) + 2 < Len(rSecondLine.Text) Or rDest.Text = "ÖÅÍÒÐ ÈÍÍÎÂÀÖÈÉ È ÂÛÑÎÊÈÕ ÒÅÕÍÎËÎÃÈÉ "
+    
+    Call target.InsertBefore(Chr(9))
+    
+    oldText = rSecondLine.Text
+    Call rSecondLine.Delete
+    Call target.InsertAfter(Chr(9))
+    Call target.InsertAfter(oldText)
+    Call rDest.InsertAfter(Chr(11))
+  End If
+End Function
+
+Private Function CleanFooter(target As Word.Range, cPos As ColontitlePosition)
+  target.Style = "Íèæíèé êîëîíòèòóë"
+  
+  Dim hasField As Boolean: hasField = target.Fields.Count > 0
+  If hasField Then
+    Call target.Fields(1).Cut
+    Call target.Delete
+    Call target.Paste
+  Else
+    Call target.Delete
+  End If
+  
+  If Not cPos.left_ And Not cPos.top_ Then _
+    Call target.InsertBefore(Chr(9))
+End Function
+
+Private Function HeadersWrap(target As Word.Range)
+'Ïîäãîí âåðõíåãî
+  Dim temprang1 As Word.Range, temprang2 As Word.Range
+  If Len(target.Text) < 70 Then
+    Call target.InsertBefore(Chr(11))
+  Else
+    Set temprang2 = target.Duplicate
+    Set temprang1 = target.Duplicate
+    temprang1.End = temprang2.Start
+    Do
+      Call temprang2.MoveStart(wdWord, 1)
+      Call temprang1.MoveEnd(wdWord, 1)
+    Loop Until Len(temprang1.Text) > Len(temprang2.Text)
+    
+    Call temprang2.InsertBefore(Chr(11))
+  End If
+End Function
+
+Private Function GetHeader(target As Word.Section, cPos As ColontitlePosition) As Word.HeaderFooter
+  Dim colID As WdHeaderFooterIndex: colID = IIf(cPos.left_, wdHeaderFooterEvenPages, wdHeaderFooterPrimary)
+  If cPos.top_ Then
+    Set GetHeader = target.Headers(colID)
+  Else
+    Set GetHeader = target.Footers(colID)
+  End If
+End Function
+
+Private Function DoLink(sMode As TSource, isNew As Boolean) As Boolean
+  DoLink = (sMode <> T_SOURCE_SECTION And sMode <> T_SOURCE_CHAPTER) Or (sMode = T_SOURCE_CHAPTER And isNew)
+End Function
+
+Private Function IsUsualSecName(sName$, target As Word.Range) As Boolean
+  IsUsualSecName = Not (ContainsSubstr(target, "Çàêëþ÷åíèå") + ContainsSubstr(target, "Ââåäåíèå") _
+  + ContainsSubstr(target, "Ïðèëîæåíèå") + IsToCHeader(sName))
+End Function
+
+Function ContainsSubstr(target As Word.Range, subText$) As Boolean
+  ContainsSubstr = False
+  If target.Words.Count < 2 Then _
+    Exit Function
+  ContainsSubstr = InStr(UCase(target.Words.First), UCase(subText)) <> 0
+End Function
+
+Private Function IsToCHeader(ByVal secName$) As Boolean
+  secName = UCase(secName)
+  IsToCHeader = InStr(secName, "ÎÃËÀÂËÅÍÈÅ") + InStr(secName, "ÑÎÄÅÐÆÀÍÈÅ")
+End Function

src/CD_Layout.bas

@@ -0,0 +1,560 @@
+Attribute VB_Name = "CD_Layout"
+Option Private Module
+Option Explicit
+
+Public Function InsertOneColomnSection(target As Word.Range)
+  Dim nEnd&: nEnd = target.End
+  Call target.InsertBreak(wdSectionBreakContinuous)
+  Call target.Document.Range(nEnd + 1, nEnd + 1).InsertBreak(wdSectionBreakContinuous)
+  Call target.Sections(1).PageSetup.TextColumns.SetCount(1)
+End Function
+
+Public Function InsertHeader(dest As Word.Range, headerName$, nLvl&)
+  Dim headerText$: headerText = Replace(headerName, Chr(11), " ")
+  headerText = Replace(headerText, "  ", " ")
+  
+  Dim prefixPosition&: prefixPosition = 1
+  Do While Not Mid(headerText, prefixPosition, 1) Like "[à-ÿÀ-ßa-zA-Z¨¸]"
+    prefixPosition = prefixPosition + 1
+  Loop
+  
+  Dim headerPrefix$
+  If prefixPosition > 1 Then headerPrefix = Left(headerText, prefixPosition - 2)
+  headerText = Right(headerText, Len(headerText) - prefixPosition + 1)
+  
+  Call dest.InsertAfter(headerText & vbNewLine)
+  Dim insRange As Word.Range: Set insRange = dest.Paragraphs.Last.Range
+  insRange.Font.Reset
+  insRange.Style = "Çàãîëîâîê " & Trim(Str(nLvl))
+  insRange.Font.Color = GetSectionHeader(insRange.Start, dest.Document).Font.Color
+  
+  If prefixPosition = 1 Then _
+    Exit Function
+  CreateEmptyField(insRange).TextFrame.TextRange.Text = headerPrefix
+End Function
+
+Public Function InsertConceptSymbol(dest As Word.Range, symbol$)
+  If symbol = "" Then _
+    Exit Function
+    
+  Dim txtShp As Word.Shape
+  Set txtShp = CreateEmptyField(dest)
+  With txtShp.TextFrame.TextRange
+    .Font.Spacing = 0
+    .ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
+    .Font.Size = CentimetersToPoints(1.08)
+    .Text = symbol
+    .Font.Color = GetSectionHeader(dest.Start, dest.Document).Font.Color
+    .Font.Name = "conceptpict"
+  End With
+  txtShp.TextFrame.AutoSize = True
+End Function
+
+Public Function InsertNewPicture(sFile$, dest As Word.Range)
+  Dim tmpRange As Word.Range: Set tmpRange = dest.Application.Selection.Range
+  
+  Dim txtShp As Word.Shape: Set txtShp = CreateEmptyField(dest)
+  txtShp.TextFrame.TextRange.Select
+  Dim picShp As Word.InlineShape: Set picShp = Selection.InlineShapes.AddPicture(sFile)
+  If picShp Is Nothing Then
+    Call UserInteraction.ShowMessage(EM_CANNOT_INSERT_IMAGE)
+    Exit Function
+  End If
+  txtShp.TextFrame.TextRange.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
+  
+  picShp.LockAspectRatio = True
+  picShp.Width = CentimetersToPoints(1)
+  txtShp.TextFrame.AutoSize = True
+  
+  Dim sPictName$: sPictName = Replace(UserInteraction.PromptInput("Ââåäèòå íàçâàíèå ïèêòîãðàììû, íàïðèìåð:" & vbNewLine & "Pict_99"), " ", "_")
+  Dim sBookmark$: sBookmark = "pict_" & sPictName
+  
+  On Error GoTo INVALID_NAME
+TRY_AGAIN:
+  Call dest.Document.Bookmarks.Add(sBookmark, txtShp.TextFrame.TextRange)
+  Call tmpRange.Select
+  Exit Function
+  
+INVALID_NAME:
+  sBookmark = "pict_" & dest.Document.Bookmarks.Count
+  Call UserInteraction.ShowMessage(IM_FIX_BOOKMARK_NAME, sBookmark)
+  GoTo TRY_AGAIN
+End Function
+
+Public Function InsertPictureRef(dest As Word.Range, bookmarkID$)
+  Dim txtShp As Word.Shape:  Set txtShp = CreateEmptyField(dest)
+  With txtShp
+    With .TextFrame.TextRange
+      .ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
+      Call .Fields.Add(txtShp.TextFrame.TextRange, Text:="REF " & bookmarkID)
+    End With
+    .TextFrame.AutoSize = True
+  End With
+End Function
+
+Public Function InsertTextField(dest As Word.Range, insText$)
+  Call dest.Collapse(wdCollapseStart)
+  Call dest.MoveEnd(wdCharacter, 1)
+  CreateEmptyField(dest).TextFrame.TextRange.Text = insText
+End Function
+
+Public Function InlineAsPNG(target As Word.InlineShape)
+  Dim isVisio As Boolean: isVisio = False
+  Dim prevW As Double: prevW = 0
+  If Not target.OLEFormat Is Nothing Then
+    If InStr(UCase(target.OLEFormat.ClassType), "VISIO") <> 0 Then
+      isVisio = True
+      prevW = target.Width
+      
+      Dim formFactor As Double: formFactor = target.Height / target.Width
+      target.LockAspectRatio = msoFalse
+      target.Width = CentimetersToPoints(20)
+      target.Height = target.Width * formFactor
+    End If
+  End If
+  
+  Dim dest As Word.Range: Set dest = target.Range.Duplicate
+  target.Select
+  target.Application.Selection.Cut
+  With dest
+    Call .Collapse(wdCollapseEnd)
+    Call .PasteSpecial(Placement:=wdInLine, DataType:=IIf(isVisio, wdPasteEnhancedMetafile, 14))
+    If isVisio Then
+      Call .MoveStart(wdCharacter, -1)
+      If .InlineShapes(1).Width < prevW Then
+        .InlineShapes(1).LockAspectRatio = msoTrue
+        .InlineShapes(1).Width = prevW
+        Call InlineAsPNG(.InlineShapes(1))
+      Else
+        Call InlineAsPNG(.InlineShapes(1))
+        Call .MoveEnd(wdCharacter, 1)
+        .InlineShapes(1).LockAspectRatio = msoTrue
+        .InlineShapes(1).Width = prevW
+      End If
+    End If
+  End With
+End Function
+
+Public Function UpdateListsLayout(target As Word.Document)
+  Call CSE_ProgressBar.InitSecondBar(0, target.ListParagraphs.Count)
+  
+  Dim aParagraph As Word.Paragraph
+  For Each aParagraph In target.ListParagraphs
+    If aParagraph.Range = target.Paragraphs.Last.Range Then _
+      GoTo NEXT_LIST
+    If aParagraph.Range.Tables.Count > 0 Then _
+      GoTo NEXT_LIST
+    
+    Dim rNext As Word.Range: Set rNext = aParagraph.Next.Range
+    If InStr(rNext.Text, Chr(12)) Or InStr(rNext.Text, Chr(14)) Then _
+      GoTo NEXT_LIST
+    If rNext.ListParagraphs.Count <> 0 Then _
+      GoTo NEXT_LIST
+      
+    Dim rCurrent As Word.Range: Set rCurrent = aParagraph.Range
+    With rCurrent.ParagraphFormat
+      .SpaceAfter = .SpaceAfter - (Int(.SpaceAfter / .LineSpacing) - 1) * .LineSpacing
+    End With
+    
+NEXT_LIST:
+    Call CSE_ProgressBar.IncrementB
+  Next aParagraph
+  Call CSE_ProgressBar.HideSecondBar
+End Function
+
+Public Function UpdateTextLayout(target As Word.Document)
+  Call FixGapsStyle(target)
+  
+  Call CSE_ProgressBar.InitSecondBar(0, target.Range.End)
+  
+  Dim aRange As Word.Range: Set aRange = target.Paragraphs.First.Range
+  Do While Not aRange Is Nothing
+    If NeedsAlignment(aRange) Then
+      Dim firstOnPage As Boolean: firstOnPage = IsFirstInColumn(aRange)
+      Dim Headers As HeaderBlock: Headers = FixHeaderBlockSpacing(aRange, firstOnPage)
+      Set aRange = Headers.finishRng
+    Else
+      Set aRange = aRange.Next(wdParagraph, 1)
+    End If
+    If Not aRange Is Nothing Then _
+      Call CSE_ProgressBar.SetB(aRange.End)
+  Loop
+  
+  Call CSE_ProgressBar.HideSecondBar
+End Function
+
+Public Function FixGapsStyle(target As Word.Document)
+  Dim rFind As Word.Range: Set rFind = target.Range.Duplicate
+  With rFind.Find
+    .Text = Chr(12)
+    Do While .Execute
+      If rFind.Previous(wdCharacter, 1) <> Chr(13) Then
+        Call rFind.InsertBefore(Chr(13))
+        If Not rFind.Start = rFind.Paragraphs.First.Range.Start Then _
+          Call rFind.MoveStart(1)
+      End If
+      rFind.ParagraphFormat.Style = "Îáû÷íûé"
+    Loop
+  End With
+End Function
+
+Public Function CreateLayoutBlock(target As Word.Range)
+  If target.End = target.Document.Range.End Then _
+    Exit Function
+
+  Dim rStart As Word.Range: Set rStart = target.Duplicate
+  Dim rFinish As Word.Range: Set rFinish = target.Next(wdParagraph, 1).Duplicate
+  Call rStart.Collapse(wdCollapseStart)
+  Call rFinish.Collapse(wdCollapseStart)
+  
+  If rStart.Start = rFinish.Start Then _
+    Exit Function
+  If GetColumn(rStart) <> GetColumn(rFinish) Then _
+    Exit Function
+  
+  Dim isFirst As Boolean: isFirst = IsFirstInColumn(target)
+  If isFirst Then target.ParagraphFormat.SpaceBefore = 0
+  
+  Dim prevAfter As Double: prevAfter = rStart.Previous(wdParagraph, 1).ParagraphFormat.SpaceAfter
+  Dim curBefore As Double: curBefore = rStart.ParagraphFormat.SpaceBefore
+  Dim curAfter As Double: curAfter = rFinish.Previous(wdParagraph, 1).ParagraphFormat.SpaceAfter
+  Dim nxtBefore As Double: nxtBefore = rFinish.ParagraphFormat.SpaceBefore
+  
+  Dim maxAfter As Double: maxAfter = IIf(curAfter > nxtBefore, curAfter, nxtBefore)
+  Dim maxBefore As Double: maxBefore = IIf(curBefore > prevAfter, curBefore, prevAfter)
+  
+  Call rFinish.Move(wdCharacter, -1)
+  Call rFinish.InsertAfter(Chr(13))
+  Call rFinish.Move(wdCharacter, 1)
+  rFinish.Style = rFinish.Document.Styles(BASE_STYLE)
+  
+  Dim topPosition As Double: topPosition = rStart.Information(wdVerticalPositionRelativeToPage)
+  If IsBorderVisible(rStart, wdBorderTop) Then _
+    topPosition = topPosition - BorderLinewidth(wdBorderTop, rStart) + rStart.Borders.DistanceFromTop
+
+  Dim botPosition As Double: botPosition = rFinish.Information(wdVerticalPositionRelativeToPage)
+  botPosition = botPosition - rFinish.Previous(wdParagraph, 1).ParagraphFormat.SpaceAfter
+  
+  Dim defSpacing As Double: defSpacing = DefaultSpacing(target.Document)
+  Dim blockHeight As Double: blockHeight = botPosition - topPosition
+  Dim nLines&: nLines = Int((blockHeight + curBefore + curAfter) / defSpacing + 0.5)
+  Dim toAdd As Double: toAdd = (nLines + 1) * defSpacing - (curBefore + curAfter + blockHeight)
+  If Abs(toAdd - defSpacing) < 0.5 Then toAdd = 0
+  
+  rFinish.Previous(wdParagraph, 1).ParagraphFormat.SpaceAfter = maxAfter + toAdd / IIf(isFirst, 1, 2)
+  rStart.ParagraphFormat.SpaceBefore = maxBefore + toAdd * IIf(isFirst, 0, 0.5)
+  If isFirst Then
+    rFinish.Previous(wdParagraph, 1).ParagraphFormat.SpaceAfter = _
+      rFinish.Previous(wdParagraph, 1).ParagraphFormat.SpaceAfter + _
+      rStart.ParagraphFormat.SpaceBefore
+    rStart.ParagraphFormat.SpaceBefore = 0
+  End If
+  
+  rFinish.Delete
+  
+  Do While rStart.ParagraphFormat.SpaceBefore > 1.4 * defSpacing And _
+      (rStart.Previous(wdParagraph, 1).ParagraphFormat.SpaceAfter > 1.4 * defSpacing Or _
+      rStart.Previous(wdParagraph, 1).ParagraphFormat.SpaceAfter = 0)
+
+    rStart.ParagraphFormat.SpaceBefore = _
+      rStart.ParagraphFormat.SpaceBefore - defSpacing
+    If rStart.Previous(wdParagraph, 1).ParagraphFormat.SpaceAfter <> 0 Then _
+      rStart.Previous(wdParagraph, 1).ParagraphFormat.SpaceAfter = _
+        rStart.Previous(wdParagraph, 1).ParagraphFormat.SpaceAfter - defSpacing
+  Loop
+
+  Do While target.Paragraphs.Last.SpaceAfter > 1.4 * defSpacing And _
+      (target.Paragraphs.Last.Next.SpaceBefore > 1.4 * defSpacing Or _
+      target.Paragraphs.Last.Next.SpaceBefore = 0)
+
+    target.Paragraphs.Last.SpaceAfter = _
+      target.Paragraphs.Last.SpaceAfter - defSpacing
+    If target.Paragraphs.Last.Next.SpaceBefore <> 0 Then _
+      target.Paragraphs.Last.Next.SpaceBefore = _
+        target.Paragraphs.Last.Next.SpaceBefore - defSpacing
+  Loop
+End Function
+
+Public Function UpdateObjectFields(target As Word.Document)
+  Call CSE_ProgressBar.InitSecondBar(0, target.Shapes.Count)
+  
+  Dim aShape As Word.Shape
+  For Each aShape In target.Shapes
+    If IsEndSymbol(aShape) Then _
+      GoTo NEXT_SHAPE
+    Dim ancRange As Word.Range: Set ancRange = aShape.Anchor.Paragraphs(1).Range
+    If Len(ancRange) < 3 Then _
+      GoTo NEXT_SHAPE
+      
+    Dim isLeft As Boolean: isLeft = GetColumn(ancRange) = T_COL_LEFT
+    With aShape
+      ' Âåðòèêàëüíîå âûðàâíèâàíèå
+      .RelativeVerticalPosition = wdRelativeVerticalPositionParagraph
+      .TextFrame.VerticalAnchor = msoAnchorBottom
+      .Top = ancRange.ParagraphFormat.SpaceBefore
+      If .TextFrame.TextRange.Font.Name = "conceptpict" Then
+        .Top = .Top - ancRange.ParagraphFormat.LineSpacing * 1.5 / 2# + .TextFrame.TextRange.ParagraphFormat.LineSpacing / 2#
+      Else
+        .TextFrame.TextRange.ParagraphFormat.LineSpacing = ancRange.ParagraphFormat.LineSpacing
+      End If
+      
+      Dim prevNormal As Word.Range: Set prevNormal = ancRange.Previous(wdParagraph)
+      Dim tmpMin As Double: tmpMin = Min(ancRange.ParagraphFormat.SpaceBefore, prevNormal.ParagraphFormat.SpaceAfter)
+      Dim tmpMax As Double: tmpMax = -Min(-ancRange.ParagraphFormat.SpaceBefore, 0)
+      .Top = .Top - IIf(ancRange.Sections.First.Range.Paragraphs.First.Range.Start = ancRange.Start, _
+              tmpMin, IIf(IsFirstInColumn(ancRange) And isLeft, tmpMax, tmpMin))
+
+      ' Ãîðèçîíòàëüíîå âûðàâíèâàíèå
+      If .Type = msoTextBox Then
+        .RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
+        If isLeft Then
+          .Left = CentimetersToPoints(LEFT_POS_SHIFT) - .Width
+          .TextFrame.TextRange.ParagraphFormat.Alignment = wdAlignParagraphRight
+        Else
+          .Left = CentimetersToPoints(RIGHT_POS_SHIFT)
+          .TextFrame.TextRange.ParagraphFormat.Alignment = wdAlignParagraphLeft
+        End If
+        If IsHeader(ancRange) Then _
+          .Top = .Top - .Height / 2# _
+            + .TextFrame.TextRange.ParagraphFormat.LineSpacing / 2# _
+            - .TextFrame.TextRange.Font.Size * (SPACING_SCALE - 1) / 2#
+      Else
+        .RelativeHorizontalPosition = IIf(isLeft, wdRelativeHorizontalPositionLeftMarginArea, wdRelativeHorizontalPositionRightMarginArea)
+        .Left = wdShapeCenter
+      End If
+    End With
+    
+NEXT_SHAPE:
+    Call CSE_ProgressBar.IncrementB
+  Next aShape
+  Call CSE_ProgressBar.HideSecondBar
+End Function
+
+Public Function UpdateTableOfContents(target As Word.TableOfContents)
+  Dim initPos As Word.Range:  Set initPos = target.Application.Selection.Range
+  
+  Call target.Update
+  Dim aLink As Hyperlink
+  For Each aLink In target.Range.Hyperlinks
+    Call aLink.Follow
+    Dim rHeader As Word.Range: Set rHeader = target.Application.Selection.Range
+    If rHeader.ParagraphFormat.OutlineLevel = wdOutlineLevel1 Then _
+      GoTo NXT_LNK
+      
+    Call rHeader.MoveStart(wdWord, -1)
+    Dim lineStart As Word.Range: Set lineStart = aLink.Range.Duplicate
+    Call lineStart.Collapse(wdCollapseStart)
+    If rHeader.ShapeRange.Count <> 0 Then
+      Dim rSource As Word.Range: Set rSource = rHeader.ShapeRange(1).TextFrame.TextRange
+      Call rSource.MoveEnd(wdCharacter, -1)
+      lineStart.Text = Chr(9) & rSource.Text & Chr(9)
+    Else
+      lineStart.Text = Chr(9) & Chr(9)
+    End If
+    
+    Call lineStart.Select
+    lineStart.ParagraphFormat.Style.BaseStyle = aLink.Range.ParagraphFormat.Style.BaseStyle
+NXT_LNK:
+  Next aLink
+  
+  Call target.Range.Document.ActiveWindow.ScrollIntoView(initPos)
+End Function
+
+' =========
+Private Function Min(i1 As Variant, i2 As Variant) As Variant
+  Min = IIf(i1 < i2, i1, i2)
+End Function
+
+Private Function IsEndSymbol(aShape As Word.Shape) As Boolean
+  IsEndSymbol = False
+  If Abs(aShape.Width - 159.875) > 1 Then Exit Function
+  If Abs(aShape.Height - 36) > 1 Then Exit Function
+  IsEndSymbol = True
+End Function
+
+Private Function FixHeaderBlockSpacing(target As Word.Range, firstOnPage As Boolean) As HeaderBlock
+  Call FixHeaderSpacing(target, firstOnPage)
+  Dim result As HeaderBlock: result = ScanHeaderBlock(target)
+  Dim kScale As Double: kScale = CalculateHeaderScaling(result, firstOnPage)
+  Call ScaleHeaderSpacing(result, kScale)
+  FixHeaderBlockSpacing = result
+End Function
+
+Private Function ScanHeaderBlock(target As Word.Range) As HeaderBlock
+  Dim result As HeaderBlock
+  
+  Set result.startRng = target.Duplicate
+  result.yText = target.ParagraphFormat.LineSpacing * target.ComputeStatistics(wdStatisticLines)
+  result.yHeight = result.yText + target.ParagraphFormat.SpaceBefore
+  
+  Set result.finishRng = result.startRng.Next(wdParagraph, 1)
+  Do While Not result.finishRng Is Nothing
+    If Not IsHeader(result.finishRng) Then _
+      Exit Do
+    If IsFirstInColumn(result.finishRng) Then _
+      Exit Do
+      
+    Call FixHeaderSpacing(result.finishRng, True)
+    
+    Dim nextLineSpacing As Double: nextLineSpacing = result.finishRng.ParagraphFormat.LineSpacing
+    result.finishRng.Previous(wdParagraph, 1).ParagraphFormat.SpaceAfter = nextLineSpacing
+    
+    Dim textH As Double: textH = nextLineSpacing * result.finishRng.ComputeStatistics(wdStatisticLines)
+    result.yText = result.yText + textH
+    result.yHeight = result.yHeight + textH + nextLineSpacing
+    
+    Set result.finishRng = result.finishRng.Next(wdParagraph, 1)
+  Loop
+  result.finishRng.Previous(wdParagraph, 1).ParagraphFormat.SpaceAfter = result.finishRng.ParagraphFormat.LineSpacing
+  result.yHeight = result.yHeight + result.finishRng.ParagraphFormat.LineSpacing
+  
+  ScanHeaderBlock = result
+End Function
+
+Private Function CalculateHeaderScaling(block As HeaderBlock, firstOnPage As Boolean) As Double
+  Dim defSpacing As Double: defSpacing = DefaultSpacing(block.startRng.Document)
+  Dim n&: n = CLng(block.yHeight / defSpacing + 0.5) ' TODO: probably should use Int istead of CLng, needs testing
+  If n = 3 And Not firstOnPage Then
+    n = n - 1
+  End If
+  Dim newH As Double: newH = n * defSpacing
+  Dim k As Double: k = (newH - block.yText) / (block.yHeight - block.yText)
+  If k < 0 Then
+    Call UserInteraction.ShowMessage(EM_FIX_LINING_FAIL)
+    Exit Function
+  End If
+  CalculateHeaderScaling = k
+End Function
+
+Private Function ScaleHeaderSpacing(block As HeaderBlock, kScale As Double)
+  Dim tmpRng As Word.Range: Set tmpRng = block.startRng.Duplicate
+  Do While Not tmpRng.Start = block.finishRng.Start
+    tmpRng.ParagraphFormat.SpaceBefore = kScale * tmpRng.ParagraphFormat.SpaceBefore
+    tmpRng.ParagraphFormat.SpaceAfter = kScale * tmpRng.ParagraphFormat.SpaceAfter
+    Set tmpRng = tmpRng.Next(wdParagraph, 1)
+  Loop
+End Function
+
+Private Function SetHeaderBlockPosition(block As HeaderBlock, firstOnPage As Boolean)
+  Dim defSpacing As Double: defSpacing = DefaultSpacing(block.startRng.Document)
+  Dim prevSpc As Double:  prevSpc = block.startRng.Previous(wdParagraph).ParagraphFormat.SpaceAfter
+  Dim curSpc As Double:   curSpc = block.startRng.ParagraphFormat.SpaceBefore
+  If prevSpc <> 0 And Not firstOnPage Then _
+    block.startRng.ParagraphFormat.SpaceBefore = prevSpc + ((curSpc * 1000) Mod (defSpacing * 1000)) / 1000
+  
+  prevSpc = block.finishRng.Previous(wdParagraph, 1).ParagraphFormat.SpaceAfter
+  curSpc = block.finishRng.ParagraphFormat.SpaceBefore
+  If curSpc <> 0 Then _
+    block.finishRng.Previous(wdParagraph, 1).ParagraphFormat.SpaceAfter = curSpc + ((1000 * prevSpc) Mod (defSpacing * 1000)) / 1000
+End Function
+
+Private Function FixHeaderSpacing(target As Word.Range, columnStart As Boolean)
+  With target
+    If Not .ParagraphFormat.LineSpacingRule = wdLineSpaceExactly Then
+      .ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
+      .ParagraphFormat.LineSpacing = .ParagraphFormat.LineSpacing * SPACING_SCALE
+    End If
+    .ParagraphFormat.Alignment = IIf(GetColumn(target) = T_COL_RIGHT, wdAlignParagraphRight, wdAlignParagraphLeft)
+    .ParagraphFormat.SpaceBefore = IIf(columnStart, 0, .ParagraphFormat.LineSpacing)
+  End With
+End Function
+
+Private Function BorderLinewidth(bordertype As WdBorderType, wdrange As Word.Range) As Double
+  BorderLinewidth = 0
+  If wdrange.Borders(bordertype).Visible = False Then Exit Function
+  Select Case wdrange.Borders(bordertype).LineWidth
+    Case wdLineWidth025pt:  BorderLinewidth = 0.25
+    Case wdLineWidth050pt:  BorderLinewidth = 0.5
+    Case wdLineWidth075pt:  BorderLinewidth = 0.75
+    Case wdLineWidth100pt:  BorderLinewidth = 1
+    Case wdLineWidth150pt:  BorderLinewidth = 1.5
+    Case wdLineWidth225pt:  BorderLinewidth = 2.25
+    Case wdLineWidth300pt:  BorderLinewidth = 3
+    Case wdLineWidth450pt:  BorderLinewidth = 4.5
+    Case wdLineWidth600pt:  BorderLinewidth = 6
+  End Select
+End Function
+
+Private Function IsBorderVisible(wdrange As Word.Range, wdBorder As WdBorderType) As Boolean
+  IsBorderVisible = wdrange.Borders.Item(wdBorder).Visible
+End Function
+
+Private Function RemoveObjectsFrom(dest As Word.Range)
+  Dim i&
+  For i = 1 To dest.ShapeRange.Count
+    Dim aShape As Word.Shape: Set aShape = dest.ShapeRange(i)
+    If aShape.Type = msoTextBox And ((GetColumn(dest) = T_COL_RIGHT And aShape.Left = Int(20 * CentimetersToPoints(RIGHT_POS_SHIFT)) / 20) _
+      Or (GetColumn(dest) = T_COL_LEFT And Abs(aShape.Left) = Int(20 * Abs(CentimetersToPoints(LEFT_POS_SHIFT) - aShape.Width)) / 20)) _
+    Then
+      Call aShape.Delete
+    End If
+  Next i
+End Function
+
+Private Function NeedsAlignment(target As Word.Range) As Boolean
+  NeedsAlignment = False
+  
+  Dim outLevel&: outLevel = target.ParagraphFormat.OutlineLevel
+  If IsHeader(target, 1) Or outLevel = wdOutlineLevel1 Then _
+    Exit Function
+  If Not IsHeader(target) Then _
+    Exit Function
+  If target.ParagraphFormat.Style = "Çàãîëîâîê îãëàâëåíèÿ" Then _
+    Exit Function
+  
+  NeedsAlignment = True
+End Function
+
+Private Function CreateEmptyField(dest As Word.Range) As Word.Shape
+  Dim selRange As Word.Range: Set selRange = dest.Application.Selection.Range
+  
+  Call RemoveObjectsFrom(dest)
+  
+  Dim txtShp As Word.Shape
+  Set txtShp = dest.Document.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, _
+    CentimetersToPoints(FIELD_SIZE_CM), dest.ParagraphFormat.LineSpacing * 1.5, dest)
+  
+  If txtShp.Anchor.Start <> dest.Start Then
+    ' ÊÎÑÒÛËÜ: Éîõîõî ñáðîñèòü ÿêîðÿ
+    txtShp.Select
+    Selection.Cut
+    dest.Select
+    Selection.Paste
+    Set txtShp = dest.ShapeRange(1)
+    selRange.Select
+    If dest.Characters.First = " " Then _
+      dest.Characters.First.Delete
+    ' End of ÊÎÑÒÛËÜ
+  End If
+  
+  With txtShp
+    ' Ôîðìèòèðîâàíèå òåêñòà
+    With .TextFrame.TextRange
+      .Font = dest.Font
+      .ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
+      .ParagraphFormat.LineSpacing = dest.ParagraphFormat.LineSpacing
+      .ParagraphFormat.SpaceBefore = 0
+      .ParagraphFormat.SpaceAfter = 0
+    End With
+    
+    ' Âûðàâíèâàíèå íà ñòðàíèöå
+    .RelativeVerticalPosition = wdRelativeVerticalPositionParagraph
+    .Top = dest.ParagraphFormat.SpaceBefore _
+        - .Height / 2# _
+        + .TextFrame.TextRange.ParagraphFormat.LineSpacing / 2#
+    
+    .RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
+    If GetColumn(dest) = T_COL_RIGHT Then
+      .Left = CentimetersToPoints(RIGHT_POS_SHIFT)
+      .TextFrame.TextRange.ParagraphFormat.Alignment = wdAlignParagraphLeft
+    Else
+      .Left = CentimetersToPoints(LEFT_POS_SHIFT) - .Width
+      .TextFrame.TextRange.ParagraphFormat.Alignment = wdAlignParagraphRight
+    End If
+    
+    ' Ðàìêà
+    .Line.Visible = msoFalse
+  End With
+  Set CreateEmptyField = txtShp
+End Function
+

src/CD_Paint.bas

@@ -0,0 +1,358 @@
+Attribute VB_Name = "CD_Paint"
+Option Private Module
+Option Explicit
+
+Public Function RepaintText(target As Word.Document)
+  CSE_ProgressBar.Header = "Ïîêðàñêà âûäåëåíèé..."
+  Call CSE_ProgressBar.InitSecondBar(0, maxVal:=target.Range.End)
+  
+  Dim sectionHead As SectionHeader: Set sectionHead.rFind = target.Range.Duplicate
+  sectionHead.nStart = 0
+  sectionHead.nFinish = -1
+  sectionHead.cHeader = wdAuto
+  sectionHead.cText = wdAuto
+  With sectionHead.rFind.Find
+    .Text = ""
+    .Format = True
+    .ParagraphFormat.OutlineLevel = wdOutlineLevel1
+  End With
+  
+  Do While IncrementHeader(sectionHead)
+    Call PaintBoldText(sectionHead)
+    Call PaintItalicText(sectionHead)
+    Call CSE_ProgressBar.SetB(sectionHead.nFinish)
+  Loop
+
+  Call CSE_ProgressBar.HideSecondBar
+End Function
+
+Public Function RepaintTextShapes(target As Word.Document)
+  CSE_ProgressBar.Header = "Ïîêðàñêà âûíîñîê íà ïîëÿõ..."
+  Call CSE_ProgressBar.InitSecondBar(0, maxVal:=target.Shapes.Count)
+  
+  Dim aShape As Word.Shape
+  For Each aShape In target.Shapes
+    If aShape.Type = msoTextBox Then
+      Dim ancRange As Word.Range: Set ancRange = aShape.Anchor.Paragraphs(1).Range
+      aShape.TextFrame.TextRange.Font.Color = GetSectionHeader(ancRange.Start, target).Font.Color
+    End If
+    Call CSE_ProgressBar.IncrementB
+  Next aShape
+  
+  Call CSE_ProgressBar.HideSecondBar
+End Function
+
+Public Function RepaintHLinks(target As Word.Document)
+  CSE_ProgressBar.Header = "Ïîêðàñêà ãèïåðññûëîê..."
+  Call CSE_ProgressBar.InitSecondBar(0, maxVal:=target.Hyperlinks.Count)
+  
+  Dim initialPos As Word.Range:  Set initialPos = target.ActiveWindow.Selection.Range
+  Dim aLink As Hyperlink
+  For Each aLink In target.Hyperlinks
+    If Not aLink.Address = "" Or aLink.SubAddress Like "_Toc*" Then _
+      GoTo NEXT_LINK
+      
+    Call aLink.Follow
+    Dim linkTarget As Word.Range: Set linkTarget = target.ActiveWindow.Selection.Paragraphs(1).Range
+    If linkTarget.ParagraphFormat.OutlineLevel <> wdOutlineLevelBodyText Then _
+      aLink.Range.Font.Color = linkTarget.Font.Color
+NEXT_LINK:
+  Call CSE_ProgressBar.IncrementB
+  Next aLink
+  
+  Call target.ActiveWindow.ScrollIntoView(initialPos)
+  Call CSE_ProgressBar.HideSecondBar
+End Function
+
+Public Function RepaintToC(target As Word.Document)
+  CSE_ProgressBar.Header = "Ïîêðàñêà îãëàâëåíèÿ..."
+  Dim i&
+  For i = 1 To target.TablesOfContents.Count Step 1
+    Call PaintToC(target.TablesOfContents(i))
+  Next i
+End Function
+
+Public Function PaintTable(target As Word.Table, mainColor&, props As TablePaintProps)
+  Dim colorFrame&: colorFrame = ColorAdjustLuma(mainColor, props.cGrid, True)
+  Dim colorHead&: colorHead = ColorAdjustLuma(mainColor, props.cHeading, True)
+  Dim colorSubhead&: colorSubhead = ColorAdjustLuma(mainColor, props.cSubHead, True)
+  Dim colorZebraBright&: colorZebraBright = 16777215 ' Áåëûé
+  Dim colorZebraDark&: colorZebraDark = ColorAdjustLuma(mainColor, props.cZebra, True)
+  
+  Dim greyColHead&:  greyColHead = ColorGetLuma(colorHead)
+  Dim greyColSub&:  greyColSub = ColorGetLuma(colorSubhead)
+  Dim greyColZebra&:  greyColZebra = ColorGetLuma(colorZebraDark)
+  
+  With target
+  ' Îáùèå ïàðàìåòðû
+    .AllowPageBreaks = True
+    .AllowAutoFit = False
+        
+    .PreferredWidthType = wdPreferredWidthPercent
+    .PreferredWidth = 100
+    
+    .Rows.HeightRule = wdRowHeightAuto
+    .Rows.Height = CentimetersToPoints(0)
+    
+    .TopPadding = CentimetersToPoints(props.textSpacing)
+    .BottomPadding = CentimetersToPoints(props.textSpacing)
+    .LeftPadding = CentimetersToPoints(props.textSpacing)
+    .RightPadding = CentimetersToPoints(props.textSpacing)
+    .Spacing = 0
+    
+  ' Ãðàíèöû
+    With .Borders(wdBorderLeft)
+      .LineStyle = wdLineStyleSingle
+      .LineWidth = TABLE_FRAME_THICKNESS
+      .Color = colorFrame
+    End With
+    With .Borders(wdBorderTop)
+      .LineStyle = wdLineStyleSingle
+      .LineWidth = TABLE_FRAME_THICKNESS
+      .Color = colorFrame
+    End With
+    With .Borders(wdBorderRight)
+      .LineStyle = wdLineStyleSingle
+      .LineWidth = TABLE_FRAME_THICKNESS
+      .Color = colorFrame
+    End With
+    With .Borders(wdBorderBottom)
+      .LineStyle = wdLineStyleSingle
+      .LineWidth = TABLE_FRAME_THICKNESS
+      .Color = colorFrame
+    End With
+    
+    With .Borders(wdBorderHorizontal)
+      .LineStyle = wdLineStyleSingle
+      .LineWidth = TABLE_CELL_THICKNESS
+      .Color = colorFrame
+    End With
+    With .Borders(wdBorderVertical)
+      .LineStyle = wdLineStyleSingle
+      .LineWidth = TABLE_CELL_THICKNESS
+      .Color = colorFrame
+    End With
+    
+    
+    With .Rows(1)
+      With .Borders(wdBorderBottom)
+        .LineStyle = wdLineStyleSingle
+        .LineWidth = TABLE_FRAME_THICKNESS
+        .Color = colorFrame
+      End With
+      
+      .Range.Font.ColorIndex = IIf(greyColHead < 127, wdWhite, wdBlack)
+      .Shading.BackgroundPatternColor = colorHead
+    End With
+  End With
+  
+  ' Îðãàíèçóåì çåáðó
+  Dim whiteFlag As Boolean: whiteFlag = True
+  Dim nRow As Integer: nRow = 2
+  For nRow = 2 To target.Rows.Count
+    If target.Cell(nRow, 1).Range.Font.Bold = True Then
+      target.Rows(nRow).Range.Font.ColorIndex = IIf(greyColSub < 127, wdWhite, wdBlack)
+      target.Rows(nRow).Shading.BackgroundPatternColor = colorSubhead
+      whiteFlag = True
+    Else
+      If whiteFlag Then
+        target.Rows(nRow).Shading.BackgroundPatternColor = colorZebraBright
+      Else
+        target.Rows(nRow).Range.Font.ColorIndex = IIf(greyColZebra < 127, wdWhite, wdBlack)
+        target.Rows(nRow).Shading.BackgroundPatternColor = colorZebraDark
+      End If
+      whiteFlag = Not whiteFlag
+    End If
+  Next nRow
+End Function
+
+Public Function PaintTableProto(target As Word.Table, proto As Word.Table)
+' Êðàñèì òàáëèöó â ñîîòâåòñòâèè ñ âûáðàííûì ïðîòîòèïîì
+  Dim colorHead&: colorHead = proto.Cell(2, 1).Shading.BackgroundPatternColor
+  Dim colorBright&: colorBright = proto.Cell(3, 1).Shading.BackgroundPatternColor
+  Dim colorDark&: colorDark = proto.Cell(4, 1).Shading.BackgroundPatternColor
+  
+  ' Îáùèå ïàðàìåòðû
+  With target
+    With .Borders(wdBorderLeft)
+      .LineStyle = proto.Borders(wdBorderLeft).LineStyle
+      .LineWidth = proto.Borders(wdBorderLeft).LineWidth
+      .Color = proto.Borders(wdBorderLeft).Color
+    End With
+    With .Borders(wdBorderTop)
+      .LineStyle = proto.Borders(wdBorderTop).LineStyle
+      .LineWidth = proto.Borders(wdBorderTop).LineWidth
+      .Color = proto.Borders(wdBorderTop).Color
+    End With
+    With .Borders(wdBorderRight)
+      .LineStyle = proto.Borders(wdBorderRight).LineStyle
+      .LineWidth = proto.Borders(wdBorderRight).LineWidth
+      .Color = proto.Borders(wdBorderRight).Color
+    End With
+    With .Borders(wdBorderBottom)
+      .LineStyle = proto.Borders(wdBorderBottom).LineStyle
+      .LineWidth = proto.Borders(wdBorderBottom).LineWidth
+      .Color = proto.Borders(wdBorderBottom).Color
+    End With
+    
+    With .Borders(wdBorderHorizontal)
+      .LineStyle = proto.Borders(wdBorderVertical).LineStyle
+      .LineWidth = proto.Borders(wdBorderVertical).LineWidth
+      .Color = proto.Borders(wdBorderVertical).Color
+    End With
+    With .Borders(wdBorderVertical)
+      .LineStyle = proto.Borders(wdBorderVertical).LineStyle
+      .LineWidth = proto.Borders(wdBorderVertical).LineWidth
+      .Color = proto.Borders(wdBorderVertical).Color
+    End With
+    
+    .Borders(wdBorderDiagonalDown).LineStyle = proto.Borders(wdBorderDiagonalDown).LineStyle
+    .Borders(wdBorderDiagonalUp).LineStyle = proto.Borders(wdBorderDiagonalUp).LineStyle
+    .Borders.Shadow = proto.Borders.Shadow
+  End With
+  
+  With target
+    .AllowPageBreaks = proto.AllowPageBreaks
+    .AllowAutoFit = proto.AllowAutoFit
+    
+    .PreferredWidthType = wdPreferredWidthPoints
+    .PreferredWidth = CentimetersToPoints(15.92)
+    .Rows.HeightRule = wdRowHeightAuto
+    .Rows.Height = CentimetersToPoints(0)
+    
+    .TopPadding = proto.TopPadding
+    .BottomPadding = proto.BottomPadding
+    .LeftPadding = proto.LeftPadding
+    .RightPadding = proto.RightPadding
+    .Spacing = proto.Spacing
+    
+    With .Rows(1)
+      .Borders(wdBorderBottom).LineStyle = proto.Rows(1).Borders(wdBorderBottom).LineStyle
+      .Borders(wdBorderBottom).LineWidth = proto.Rows(1).Borders(wdBorderBottom).LineWidth
+      .Borders(wdBorderBottom).Color = proto.Rows(1).Borders(wdBorderBottom).Color
+      .Shading.BackgroundPatternColor = proto.Cell(1, 1).Shading.BackgroundPatternColor
+    End With
+  End With
+  
+  ' Îðãàíèçóåì çåáðó
+  Dim whiteFlag As Boolean: whiteFlag = True
+  Dim nRow&: nRow = 2
+  For nRow = 2 To target.Rows.Count
+    If target.Cell(nRow, 1).Range.Font.Bold = True Then
+      target.Rows(nRow).Shading.BackgroundPatternColor = colorHead
+      whiteFlag = True
+    Else
+      If whiteFlag Then
+        target.Rows(nRow).Shading.BackgroundPatternColor = colorBright
+      Else
+        target.Rows(nRow).Shading.BackgroundPatternColor = colorDark
+      End If
+      whiteFlag = Not whiteFlag
+    End If
+  Next nRow
+End Function
+
+' ==========
+Private Function PaintToC(target As Word.TableOfContents)
+  Dim tocElement As Word.Range: Set tocElement = target.Range.Paragraphs.First.Range
+  Dim rHeader As Word.Range: Set rHeader = target.Range.Document.Range
+  With rHeader.Find
+    .Text = ""
+    .Format = True
+    .ParagraphFormat.OutlineLevel = wdOutlineLevel1
+  End With
+  
+  On Error GoTo REPORT_ERROR
+  Dim theEnd&: theEnd = target.Range.End
+  Do While rHeader.Find.Execute
+    If Len(rHeader.Text) < 3 Then _
+      GoTo NEXT_SECTION_HEADER
+    
+    Do While Not tocElement.Font.AllCaps = True
+      Set tocElement = tocElement.Next(wdParagraph, 1)
+      If tocElement.End > theEnd Then _
+        GoTo REPORT_ERROR
+    Loop
+    tocElement.Font.Color = rHeader.Font.Color
+    Set tocElement = tocElement.Next(wdParagraph, 1)
+    
+NEXT_SECTION_HEADER:
+    Call rHeader.Collapse(wdCollapseEnd)
+  Loop
+  Exit Function
+REPORT_ERROR:
+  Call UserInteraction.ShowMessage(EM_INVALID_CONTENTS_TABLE)
+End Function
+
+Private Function IncrementHeader(ByRef target As SectionHeader) As Boolean
+  IncrementHeader = False
+  If target.nFinish >= target.rFind.Document.Sections.Last.Range.Start - 1 Then _
+    Exit Function
+  If Not target.rFind.Find.Execute Then _
+    Exit Function
+    
+  Dim theHeader As Word.Range: Set theHeader = target.rFind.Duplicate
+  Dim lastSection As Boolean: lastSection = Not target.rFind.Find.Execute
+  Do While Len(target.rFind.Text) < 3 And Not lastSection
+    Call target.rFind.Collapse(wdCollapseEnd)
+    lastSection = Not target.rFind.Find.Execute
+  Loop
+  
+  Call target.rFind.Collapse(wdCollapseStart)
+  target.nStart = theHeader.End + 1
+  target.nFinish = IIf(lastSection, target.rFind.Document.Sections.Last.Range.Start - 1, target.rFind.Start - 1)
+  target.cText = ColorGetRGB(theHeader.Font.Color, target.rFind.Document)
+  target.cHeader = ColorAdjustLuma(target.cText, 1000 * TEXT_BOLD_LUMSCALE, True)
+  
+  IncrementHeader = True
+End Function
+
+Private Function PaintBoldText(target As SectionHeader)
+  Dim rFind As Word.Range: Set rFind = target.rFind.Document.Range(target.nStart, target.nStart)
+  With rFind
+    .Find.Text = ""
+    .Find.Format = True
+    .Find.Font.Bold = True
+    
+    Do While .Find.Execute And .End < target.nFinish
+      If .OMaths.Count > 0 Or .Tables.Count > 0 Then _
+        GoTo NEXT_RANGE
+      If .Style Like "*Ôîðìóëà*" Then _
+        GoTo NEXT_RANGE
+      If Not .CharacterStyle Is Nothing Then
+        If .CharacterStyle Like "*Ôîðìóëà*" Then _
+          GoTo NEXT_RANGE
+      End If
+      
+      .Font.Color = IIf(.ParagraphFormat.OutlineLevel = wdOutlineLevelBodyText, target.cText, target.cHeader)
+      
+NEXT_RANGE:
+      Call .Collapse(wdCollapseEnd)
+    Loop
+  End With
+End Function
+
+Private Function PaintItalicText(target As SectionHeader)
+  Dim rFind As Word.Range: Set rFind = target.rFind.Document.Range(target.nStart, target.nStart)
+  With rFind
+    .Find.Text = ""
+    .Find.Format = True
+    .Find.Font.Italic = True
+    
+    Do While .Find.Execute And .End < target.nFinish
+      If .OMaths.Count > 0 Or .Tables.Count > 0 Then _
+        GoTo NEXT_RANGE
+      If .Style Like "*Ôîðìóëà*" Then _
+        GoTo NEXT_RANGE
+      If Not .CharacterStyle Is Nothing Then
+        If .CharacterStyle Like "*Ôîðìóëà*" Then _
+          GoTo NEXT_RANGE
+      End If
+    
+      .Font.Color = IIf(.ParagraphFormat.OutlineLevel = wdOutlineLevelBodyText, target.cText, target.cHeader)
+      
+NEXT_RANGE:
+      Call .Collapse(wdCollapseEnd)
+    Loop
+  End With
+End Function

src/CD_RedesignFonts.bas

@@ -0,0 +1,115 @@
+Attribute VB_Name = "CD_RedesignFonts"
+Option Private Module
+Option Explicit
+
+Public Function ExecuteRedesign(target As Word.Document, props As ItemFontScale)
+  target.Styles(BASE_STYLE).ParagraphFormat.LineSpacing = props.lineSpacing_
+  target.Styles(BASE_STYLE).Font.Size = props.textSize_
+  
+  Call CSE_ProgressBar.Init("Èçìåíåíèå øðèôòîâ", maxVal:=3)
+  Call CSE_ProgressBar.ShowModeless
+  
+  Call RedesignHeader(target, props)
+  Call CSE_ProgressBar.IncrementA
+  
+  Call RedesignRegularStyles(target, props)
+  Call CSE_ProgressBar.IncrementA
+  
+  Call RedesignText(target, props)
+  Call CSE_ProgressBar.IncrementA
+  
+  Unload CSE_ProgressBar
+End Function
+
+' ===========
+Private Function RedesignHeader(target As Word.Document, props As ItemFontScale)
+  CSE_ProgressBar.Header = "Èçìåíåíèå çàãîëîâêîâ"
+  Call CSE_ProgressBar.InitSecondBar(0, target.Styles.Count)
+  Dim aStyle As Word.Style
+  For Each aStyle In target.Styles
+    If Not IsStyleMajor(aStyle) Then _
+      GoTo NEXT_STYLE
+    
+    aStyle.Font.Size = aStyle.Font.Size * props.fontMultiplier_
+    
+    If Not RequiresSpacingFix(aStyle) Then _
+      GoTo NEXT_STYLE
+    
+    Dim oldScale As Double: oldScale = GetStyleScale(aStyle, props.fontFactor_)
+    With aStyle.ParagraphFormat
+      .LineSpacing = .LineSpacing * props.fontMultiplier_ * props.spacing_ / oldScale
+      .SpaceAfter = .SpaceAfter * props.fontMultiplier_ * props.spacing_ / oldScale
+      .SpaceBefore = .SpaceBefore * props.fontMultiplier_ * props.spacing_ / oldScale
+    End With
+NEXT_STYLE:
+    Call CSE_ProgressBar.IncrementB
+  Next aStyle
+  
+  Call CSE_ProgressBar.HideSecondBar
+End Function
+
+Private Function RedesignRegularStyles(target As Word.Document, props As ItemFontScale)
+  CSE_ProgressBar.Header = "Èçìåíåíèå áàçîâîãî òåêñòà"
+  Call CSE_ProgressBar.InitSecondBar(0, target.Styles.Count)
+  
+  Dim aStyle As Word.Style
+  For Each aStyle In target.Styles
+    If Not RequiresRegularFix(aStyle) Then _
+      GoTo NEXT_STYLE
+    With aStyle.ParagraphFormat
+      .SpaceAfter = .SpaceAfter * props.fontMultiplier_ * props.spacing_
+      .SpaceBefore = .SpaceBefore * props.fontMultiplier_ * props.spacing_
+    End With
+NEXT_STYLE:
+    Call CSE_ProgressBar.IncrementB
+  Next aStyle
+  
+  Call CSE_ProgressBar.HideSecondBar
+End Function
+
+Private Function RedesignText(target As Word.Document, props As ItemFontScale)
+  CSE_ProgressBar.Header = "Èçìåíåíèå îòñòóïîâ"
+  Call CSE_ProgressBar.InitSecondBar(0, target.ListParagraphs.Count)
+  
+  Dim para As Word.Paragraph
+  For Each para In target.ListParagraphs
+    If Not IsHeader(para.Range) And para.SpaceAfter <> 0 Then _
+      para.SpaceAfter = props.lineSpacing_
+    CSE_ProgressBar.IncrementB
+  Next para
+  
+  Call CSE_ProgressBar.HideSecondBar
+End Function
+
+Private Function IsStyleMajor(aStyle As Word.Style) As Boolean
+  IsStyleMajor = _
+    aStyle.NameLocal Like "[Îî]ãëàâëåíèå*" Or _
+    aStyle.NameLocal Like "[Çç]àãîëîâîê [Îî]ãëàâëåíèÿ" Or _
+    aStyle.NameLocal Like "[Íí]àçâàíèå îáúåêòà" Or _
+    aStyle.NameLocal Like "[Çç]àãîëîâîê #" Or _
+    aStyle.NameLocal Like "[Òò]àáëèöà*"
+End Function
+
+Private Function RequiresSpacingFix(aStyle As Word.Style)
+  RequiresSpacingFix = _
+    aStyle.NameLocal Like "[Çç]àãîëîâîê #" Or _
+    aStyle.NameLocal Like "[Òò]àáëèöà*"
+End Function
+
+Private Function RequiresRegularFix(aStyle As Word.Style)
+  RequiresRegularFix = _
+    UCase(aStyle.NameLocal) Like "!ÀÁÇÀÖ ÂÀÆÍÎ" Or _
+    UCase(aStyle.NameLocal) Like "!ÀÁÇÀÖ Ñ ÐÀÌÊÎÉ" Or _
+    UCase(aStyle.NameLocal) Like "ÔÎÐÌÓËÀ"
+End Function
+
+Private Function GetStyleScale(aStyle As Word.Style, fontFactor As Double) As Double
+  Dim spacingType As WdLineSpacing: spacingType = aStyle.ParagraphFormat.LineSpacingRule
+  Select Case (spacingType)
+  Case wdLineSpace1pt5: GetStyleScale = 1.5
+  Case wdLineSpaceDouble: GetStyleScale = 2
+  Case wdLineSpaceMultiple: GetStyleScale = aStyle.ParagraphFormat.LineSpacing
+  Case wdLineSpaceExactly: GetStyleScale = aStyle.ParagraphFormat.LineSpacing / aStyle.Font.Size / fontFactor
+  Case Else: GetStyleScale = 1
+  End Select
+End Function

src/CD_SplitTable.bas

@@ -0,0 +1,307 @@
+Attribute VB_Name = "CD_SplitTable"
+Option Private Module
+Option Explicit
+
+Public Function PrepareTableForSplit(target As Word.Table)
+  Call SetupPageBeforeSlice(target)
+  Call InsertSplittingMarker(target)
+End Function
+
+Public Function RemoveSplitMarkerFrom(target As Word.Table)
+  On Error Resume Next
+  target.Cell(1, 1).Range.ShapeRange.Delete
+End Function
+
+Public Function SliceTable(target As Word.Table) As Collection
+  Dim startingRows As Collection: Set startingRows = PrepareStartingRows(target)
+
+  Dim slices As New Collection
+  Dim nIndex&
+  For nIndex = startingRows.Count To 2 Step -1
+    Call target.Rows(1).Select
+    target.Application.Selection.Copy
+    Dim rPaste As Word.Range: Set rPaste = target.Range
+    Call rPaste.Collapse(wdCollapseEnd)
+    Call rPaste.InsertBreak(wdSectionBreakNextPage)
+    Call rPaste.Paste
+    
+    Dim rowStart&: rowStart = startingRows(nIndex)
+    Dim rowFinish&: rowFinish = target.Rows.Count + 1
+    target.Rows(rowStart).Select
+    Dim k&
+    For k = 1 To rowFinish - rowStart - 1
+      Call Selection.MoveDown(wdLine, Extend:=wdExtend)
+    Next k
+    
+    target.Application.Selection.Copy
+    Call rPaste.Collapse(wdCollapseEnd)
+    Call rPaste.Paste
+    target.Application.Selection.Rows.Delete
+    
+    Call slices.Add(rPaste.Sections.First.Range.Tables(1))
+  Next nIndex
+  Call slices.Add(target)
+  
+  Set SliceTable = slices
+End Function
+
+Public Function SplitSlices(slices As Collection)
+  Call CSE_ProgressBar.InitSecondBar(0, slices.Count)
+  Dim tablePart As Variant
+  For Each tablePart In slices
+    Call tablePart.Select
+    Call SplitTable(tablePart.Application.Selection.Tables(1))
+    CSE_ProgressBar.IncrementB
+  Next tablePart
+  CSE_ProgressBar.HideSecondBar
+End Function
+
+' ============
+Private Function SplitTable(target As Word.Table)
+  If target.Rows(1).Cells.Count = 0 Then
+    Call UserInteraction.ShowMessage(EM_TABLE_MERGED_CELLS)
+    Exit Function
+  End If
+  
+  Dim horiz As Double, vert As Double
+  Dim tmpRange As Word.Range
+  Set tmpRange = target.Application.Selection.Document.Range(target.Range.End - 1, target.Range.End - 1)
+  horiz = tmpRange.Information(wdHorizontalPositionRelativeToPage)
+  vert = tmpRange.Information(wdVerticalPositionRelativeToPage)
+  
+  Dim runner As Variant
+  If target.Rows(1).Cells.Count < 2 Then
+    Call UserInteraction.ShowMessage(EM_INVALID_TABLE_COLUMNS)
+    Exit Function
+  End If
+  
+  For Each runner In target.Rows(1).Cells
+    Set tmpRange = runner.Range
+    Call tmpRange.Collapse(wdCollapseStart)
+    If PointsToCentimeters(tmpRange.Information(wdHorizontalPositionRelativeToPage)) > TABLE_CRITICAL_WIDTH Then
+      runner.Select
+      GoTo SELECT_MOVE
+    End If
+  Next runner
+  
+SELECT_MOVE:
+  Set tmpRange = target.Application.Selection.Range
+  Call tmpRange.Collapse(wdCollapseEnd)
+  
+  Do While tmpRange.Information(wdHorizontalPositionRelativeToPage) <> horiz
+    Call target.Application.Selection.MoveRight(wdCharacter, Extend:=wdExtend)
+    Set tmpRange = target.Application.Selection.Range
+    Call tmpRange.Collapse(wdCollapseEnd)
+  Loop
+  
+  Do While tmpRange.Information(wdVerticalPositionRelativeToPage) <> vert Or tmpRange.End <> target.Range.End - 1
+    Call Selection.MoveDown(wdLine, Extend:=wdExtend)
+    Set tmpRange = target.Application.Selection.Range
+    Call tmpRange.Collapse(wdCollapseEnd)
+  Loop
+  
+  Do While tmpRange.Information(wdHorizontalPositionRelativeToPage) <> horiz
+    Call target.Application.Selection.MoveRight(wdCharacter, Extend:=wdExtend)
+    Set tmpRange = target.Application.Selection.Range
+    Call tmpRange.Collapse(wdCollapseEnd)
+  Loop
+  
+  Set tmpRange = target.Range
+  Call tmpRange.Collapse(wdCollapseEnd)
+
+  Call tmpRange.Collapse(wdCollapseEnd)
+  Call tmpRange.InsertBreak(wdSectionBreakNextPage)
+  tmpRange.Collapse (wdCollapseEnd)
+  
+  Dim nmeRng As Word.Range
+  Set nmeRng = target.Range.Document.Range(target.Range.Sections(1).Range.Start, target.Range.Start)
+  
+  Dim beforeTable As Double: beforeTable = TabNameHeight(target)
+  If beforeTable > 0 Then
+    Call nmeRng.Copy
+    tmpRange.Paste
+    tmpRange.Collapse (wdCollapseEnd)
+    nmeRng.Font.ColorIndex = wdWhite
+  End If
+  
+  target.Application.Selection.Copy
+  tmpRange.Paste
+  target.Application.Selection.Columns.Delete
+  
+  Dim curSec As Word.Section, nextSec As Word.Section
+  Set curSec = target.Range.Sections.First
+  Set nextSec = tmpRange.Sections.First
+  
+  Call DoPortraitPageSetup(curSec.PageSetup)
+  Call DoPortraitPageSetup(nextSec.PageSetup)
+  
+  target.PreferredWidthType = wdPreferredWidthPoints
+  target.PreferredWidth = CentimetersToPoints(21 - 2 * FIELD_SIZE_CM)
+  
+  Dim victim As Word.Table
+  Set victim = nextSec.Range.Tables(1)
+  victim.PreferredWidthType = wdPreferredWidthPoints
+  victim.PreferredWidth = CentimetersToPoints(21 - 2 * FIELD_SIZE_CM)
+  
+  Dim tSecBot As Double, vSecBot As Double
+  tSecBot = target.Range.Sections(1).PageSetup.BottomMargin
+  vSecBot = victim.Range.Sections(1).PageSetup.BottomMargin
+  
+  target.Range.Sections(1).PageSetup.BottomMargin = tSecBot / 4
+  victim.Range.Sections(1).PageSetup.BottomMargin = vSecBot / 4
+  Dim i As Integer, tH As Double, vH As Double
+  For i = 1 To target.Rows.Count Step 1
+    tH = Badheight(target.Rows(i))
+    vH = Badheight(victim.Rows(i))
+    target.Rows(i).HeightRule = wdRowHeightExactly
+    victim.Rows(i).HeightRule = wdRowHeightExactly
+    target.Rows(i).Height = IIf(tH > vH, tH, vH) - 3
+    victim.Rows(i).Height = IIf(tH > vH, tH, vH) - 3
+  Next i
+  
+  target.Range.Sections(1).PageSetup.BottomMargin = tSecBot
+  victim.Range.Sections(1).PageSetup.BottomMargin = vSecBot
+  
+  If target.Cell(1, 1).Range.Information(wdActiveEndPageNumber) <> _
+    target.Rows.Last.Cells(1).Range.Information(wdActiveEndPageNumber) Then
+    target.Rows.Last.HeightRule = wdRowHeightAuto
+  End If
+
+  If victim.Cell(1, 1).Range.Information(wdActiveEndPageNumber) <> _
+    victim.Rows.Last.Cells(1).Range.Information(wdActiveEndPageNumber) Then
+    victim.Rows.Last.HeightRule = wdRowHeightAuto
+  End If
+End Function
+
+Private Function RowHeight(wdrow As Word.Row) As Double
+  Dim tmpCell As Variant
+  Dim jumper As Word.Range, strt As Double, ent As Double, tmpMax As Double
+  Dim bln As Boolean: bln = Application.ScreenUpdating
+  Application.ScreenUpdating = False
+  For Each tmpCell In wdrow.Cells
+    Set jumper = tmpCell.Range
+    Set jumper = jumper.Document.Range(jumper.End - 1, jumper.End - 1)
+    jumper.InsertAfter (Chr(11))
+    
+    Set jumper = tmpCell.Range
+    Set jumper = jumper.Document.Range(jumper.Start, jumper.Start)
+    strt = jumper.Information(wdVerticalPositionRelativeToPage)
+    Set jumper = tmpCell.Range
+    Set jumper = jumper.Document.Range(jumper.End - 1, jumper.End - 1)
+    ent = jumper.Information(wdVerticalPositionRelativeToPage)
+    
+    Set jumper = tmpCell.Range
+    Set jumper = jumper.Document.Range(jumper.End - 2, jumper.End - 1)
+    jumper.Delete
+    tmpMax = IIf(tmpMax > ent - strt + jumper.ParagraphFormat.SpaceAfter, tmpMax, ent - strt + jumper.ParagraphFormat.SpaceAfter)
+  Next tmpCell
+  Application.ScreenUpdating = bln
+  RowHeight = tmpMax
+End Function
+
+Private Function Badheight(wdrow As Word.Row) As Double
+  Dim strt As Double, ent As Double
+  strt = wdrow.Cells(1).Range.Information(wdVerticalPositionRelativeToPage)
+  ent = InsertFictiveAfter(wdrow)
+  Badheight = IIf(ent > strt, ent - strt, CentimetersToPoints(TABLE_CRITICAL_HEIGHT) - strt)
+End Function
+
+Private Function InsertFictiveAfter(wdrow As Word.Row) As Double
+  wdrow.Select
+  With wdrow.Application.Selection
+    .InsertRowsBelow (1)
+    .Font.Size = 1
+    .Font.Scaling = 1
+    .Rows.HeightRule = wdRowHeightExactly
+    .Rows.Height = 0
+    InsertFictiveAfter = .Range.Information(wdVerticalPositionRelativeToPage)
+    Selection.Rows.Delete
+  End With
+End Function
+
+Private Function TabNameHeight(wdTable As Word.Table) As Double
+  If wdTable.Range.Start = wdTable.Range.Sections.First.Range.Start Then
+    TabNameHeight = -1
+    Exit Function
+  End If
+
+  Dim nameRange As Word.Range
+  With wdTable.Range
+    Set nameRange = .Document.Range(.Sections.First.Range.Start, .Start)
+  End With
+  
+  Dim tmpRange As Word.Range
+  Dim cumHeight As Double
+  With nameRange
+    
+    Set tmpRange = .Duplicate
+    Call tmpRange.Collapse(wdCollapseStart)
+    cumHeight = tmpRange.Information(wdVerticalPositionRelativeToPage) - tmpRange.ParagraphFormat.SpaceBefore
+    
+    Set tmpRange = .Duplicate
+    Call tmpRange.Collapse(wdCollapseEnd)
+    cumHeight = tmpRange.Information(wdVerticalPositionRelativeToPage) _
+      - tmpRange.ParagraphFormat.SpaceBefore - cumHeight - 3
+  End With
+  
+  TabNameHeight = IIf(cumHeight < 0, 0, cumHeight)
+End Function
+
+' ============
+Private Function SetupPageBeforeSlice(target As Word.Table)
+  Call DoPortraitPageSetup(target.Range.Sections.First.PageSetup)
+  With target.Range.Sections.First.PageSetup
+    .PageWidth = 2 * .PageWidth - 2 * .LeftMargin
+    target.PreferredWidthType = wdPreferredWidthPoints
+    target.PreferredWidth = .PageWidth - .LeftMargin - .RightMargin
+  End With
+End Function
+
+Private Function DoPortraitPageSetup(ByRef pSetup As PageSetup)
+  With pSetup
+    .Orientation = wdOrientPortrait
+    .PageHeight = CentimetersToPoints(29.7)
+    .PageWidth = CentimetersToPoints(21)
+    .TopMargin = CentimetersToPoints(FIELD_SIZE_CM)
+    .BottomMargin = .TopMargin
+    .LeftMargin = CentimetersToPoints(FIELD_SIZE_CM)
+    .RightMargin = .LeftMargin
+  End With
+End Function
+
+Private Function PrepareStartingRows(target As Word.Table) As Collection
+  Dim startingRows As New Collection
+  Dim previousY As Double: previousY = -1
+  Dim nRow&
+  For nRow = 1 To target.Rows.Count
+    Dim currentY As Double: currentY = target.Rows(nRow).Cells(1).Range.Information(wdVerticalPositionRelativeToPage)
+    If currentY < previousY Or Badheight(target.Rows(nRow - 1)) > CentimetersToPoints(TABLE_CRITICAL_HEIGHT) Then
+      Call startingRows.Add(nRow)
+    End If
+    previousY = currentY
+  Next nRow
+  
+  Set PrepareStartingRows = startingRows
+End Function
+
+Private Function InsertSplittingMarker(target As Word.Table)
+  Dim pSetup As PageSetup: Set pSetup = target.Range.Sections.First.PageSetup
+  Dim center As Double: center = (pSetup.PageWidth - 2 * pSetup.TopMargin) / 2
+  Dim firstCell As Word.Cell: Set firstCell = target.Cell(1, 1)
+  
+  Call firstCell.Select
+  Dim sMarker As Word.Shape
+  Set sMarker = target.Parent.Shapes.AddShape(msoShapeDownArrow, center - 15, 0, 30, 60)
+  sMarker.Fill.ForeColor.RGB = RGB(112, 48, 160)
+  sMarker.Select
+  target.Application.Selection.Cut
+  Call firstCell.Range.Characters.First.Paste
+  
+  Dim markerAncore As Word.ShapeRange: Set markerAncore = firstCell.Range.ShapeRange
+  With markerAncore
+    .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
+    .RelativeVerticalPosition = wdRelativeVerticalPositionPage
+    .Left = center - 15
+    .Top = -pSetup.TopMargin
+  End With
+End Function

src/CD_WordModule.bas

@@ -0,0 +1,122 @@
+Attribute VB_Name = "CD_WordModule"
+Option Private Module
+Option Explicit
+
+Public Function GetSectionHeader(aPos&, theDoc As Word.Document) As Word.Range
+' Âîçâðàùàåò ðåíäæ ñ çàãîëîâêîì äëÿ ðàçäåëà, â êîòîðîì íàõîäèòñÿ äàííàÿ ïîçèöèÿ
+  Dim rFind As Word.Range: Set rFind = theDoc.Range(aPos, aPos)
+  With rFind.Find
+    .Text = ""
+    .Format = True
+    .Forward = False
+    .ParagraphFormat.OutlineLevel = wdOutlineLevel1
+    
+    If .Execute = False Then _
+      Exit Function
+    
+    Do While Len(rFind.Text) < 3
+      rFind.Collapse Direction:=wdCollapseStart
+      If .Execute = False Then _
+        Exit Function
+    Loop
+  End With
+  If rFind.Start <= aPos Then _
+    Set GetSectionHeader = rFind
+End Function
+
+Public Function DefaultSpacing(theDoc As Word.Document) As Double
+  DefaultSpacing = theDoc.Styles(BASE_STYLE).ParagraphFormat.LineSpacing
+End Function
+
+Public Function GetColumn(aRange As Word.Range) As TColumn
+' Ôóíêöèÿ ïðîâåðÿåò íàõîäèòñÿ ëè çàäàííûé äèàïàçîí â ëåâîé êîëîíêå èëè â ïðàâîé
+  Call CleanBeginning(aRange)
+  Dim wordX As Double: wordX = aRange.Information(wdHorizontalPositionRelativeToPage)
+  If wordX > SECOND_COL_POS Then
+    GetColumn = T_COL_RIGHT
+  Else
+    GetColumn = T_COL_LEFT
+  End If
+End Function
+
+Public Function IsHeader(aRange As Word.Range, Optional uplim As Integer = 9) As Boolean
+' Ïðîâåðÿåì çàãîëîâîê èëè íåò
+  IsHeader = True
+
+  If aRange.Tables.Count <> 0 Or aRange.Hyperlinks.Count <> 0 Then _
+    GoTo RETURN_FALSE
+    
+  If Not aRange.Style Is Nothing Then
+    If aRange.Style Like "[Çç]àãîëîâîê #*" Then
+      If CInt(Mid(aRange.Style, 11, 1)) <= uplim Then
+        Exit Function
+      ElseIf uplim < 9 Then
+        GoTo RETURN_FALSE
+      End If
+    End If
+  End If
+  
+  If aRange.ParagraphFormat.OutlineLevel <= uplim Then
+    Exit Function
+  ElseIf uplim < 9 Then
+    GoTo RETURN_FALSE
+  End If
+  
+  If Not aRange.Style Is Nothing Then _
+    If aRange.Style Like "*[Çç]àãîëîâîê*" Then _
+      Exit Function
+
+RETURN_FALSE:
+  IsHeader = False
+End Function
+
+Public Function IsFirstInColumn(aRange As Word.Range) As Boolean
+' Ïðîâåðÿåì ïåðâûé ëè çàãîëîâîê â êîëîíêå
+  IsFirstInColumn = True
+  If aRange.Characters.First Like "[" & Chr(12) & Chr(14) & "]" Then
+    Call CleanBeginning(aRange)
+    Exit Function
+  End If
+  
+  Dim prevRange As Word.Range: Set prevRange = aRange.Previous(wdParagraph, 1)
+  If prevRange Is Nothing Then _
+    Exit Function
+      
+  If prevRange.PageSetup.TextColumns.Count < 2 Then _
+    Exit Function
+  If Not GetColumn(aRange) = GetColumn(prevRange.Words.Last) Then _
+    Exit Function
+  If prevRange.Information(wdActiveEndPageNumber) <> aRange.Information(wdActiveEndPageNumber) Then _
+    Exit Function
+
+  IsFirstInColumn = False
+End Function
+
+Public Function FontLineSpacing(wdFont As Word.Font) As Double
+  Dim wdrange As Word.Range:  Set wdrange = ActiveDocument.Range.Duplicate
+  Call wdrange.Collapse(wdCollapseEnd)
+  wdrange.InsertBreak (0)
+  Call wdrange.InsertAfter(Chr(13) & Chr(13) & Chr(13) & Chr(13))
+  
+  wdrange.Font = wdFont
+  With wdrange.ParagraphFormat
+    .SpaceBefore = 0
+    .SpaceAfter = 0
+    .LineSpacingRule = wdLineSpaceSingle
+  End With
+  
+  Dim upper As Double, lower As Double
+  lower = wdrange.Paragraphs(3).Range.Information(wdVerticalPositionRelativeToPage)
+  upper = wdrange.Paragraphs(1).Range.Information(wdVerticalPositionRelativeToPage)
+  FontLineSpacing = (lower - upper) / 2 / wdFont.Size
+  FontLineSpacing = Int(FontLineSpacing / 0.05 + 0.5) * 0.05 * wdFont.Size
+  FontLineSpacing = Int(FontLineSpacing / 0.05 + 0.5) * 0.05
+  
+  Call wdrange.MoveStart(wdCharacter, -2)
+  wdrange.Delete
+End Function
+
+' ==========
+Private Function CleanBeginning(target As Word.Range)
+  Call target.MoveStartWhile(Chr(12) & Chr(14))
+End Function

src/Declarations.bas

@@ -0,0 +1,136 @@
+Attribute VB_Name = "Declarations"
+Option Explicit
+
+' TODO: refactor this whole mess
+Public Const FOOTER_SYMBOL_BREAK = 30
+
+Public Const CSET_SLETTERS = "àáâãäå¸æçèéêëìíîïðñòóôõö÷øùúûüýþÿabcdefghijklmnopqrstuvwxyz"
+Public Const CSET_BLETTERS = "ÀÁÂÃÄŨÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞßABCDEFGHIJKLMNOPQRSTUVWXYZ"
+
+Public Const BASE_STYLE = "!Àáçàö òåêñòà"
+
+Public Const FIELD_SIZE_CM As Double = 2.54
+
+' Íàñêîëüêî òåìíåå áóäåò âûäåëåíèå â òåêñòå îòíîñèòåëüíî çàãîëîâêà
+Public Const TEXT_BOLD_LUMSCALE = -0.2
+
+' Íàñòðîéêè îòòåíêîâ äëÿ òàáëèö
+Public Const TABLE_FRAME_LUMSCALE = -0.35
+Public Const TABLE_HEAD_LUMSCALE = 0.2
+Public Const TABLE_SUBHEAD_LUMSCALE = 0.3
+Public Const TABLE_ZEBRA_LUMSCALE = 0.8
+Public Const TABLE_FRAME_THICKNESS = 18
+Public Const TABLE_CELL_THICKNESS = 12
+
+Public Const SECOND_COL_POS = 300
+
+Public Const TABLE_CRITICAL_WIDTH As Double = 16
+Public Const TABLE_CRITICAL_HEIGHT As Double = 22
+
+Public Const RIGHT_POS_SHIFT = 8#
+Public Const LEFT_POS_SHIFT = -0.25
+
+' Â çàâèñèìîñòè îò øðèôòà çàãîëîâê àíóæíî ñòàâèòü ñïåöèàëüíóþ êîíñòàíòó
+Public Const SPACING_SCALE = 1.15 ' Times New Roman
+  
+' Èäåíòèôèêàòîð êîëîíêè (ëåâî-ïðàâî)
+Public Enum TColumn
+  T_COL_LEFT
+  T_COL_RIGHT
+End Enum
+
+' Ðåæèì íàïîëíåíèÿ êîëîíòèòóëà
+Public Enum TSource
+  T_SOURCE_BOOK
+  T_SOURCE_VOLUME
+  T_SOURCE_SECTION
+  T_SOURCE_DOCUMENT
+  T_SOURCE_CHAPTER
+  T_SOURCE_CONCEPT
+End Enum
+
+' Òèï êîëîíòèòóëà
+Public Type ColontitlePosition
+  top_ As Boolean
+  left_ As Boolean
+  source_ As TSource
+End Type
+
+' Íàñòðîéêà ðàñêðàñêè òàáëèöû
+Public Type TablePaintProps
+  cGrid As Long
+  cHeading As Long
+  cSubHead As Long
+  cZebra As Long
+  sectionColor As Long
+  textSpacing As Double
+End Type
+
+' Ïàðàìåòðû áëîêà çàãîëîâêîâ
+Public Type HeaderBlock
+  yText As Double
+  yHeight As Double
+  startRng As Word.Range
+  finishRng As Word.Range
+End Type
+
+' Íàñòðîéêà àâòîìàêèòèðîâàíèÿ
+Public Type AutoDesignOptions
+  reapplyLists As Boolean
+  fixObjects As Boolean
+  titlePage As Boolean
+  doLayout As Boolean
+  generateColontitles As Boolean
+  
+  Count As Integer
+End Type
+
+' Ïàðàìåòðû òèòóëüíîé ñòðàíèöû
+Public Type TitlePageData
+  sVolume As String
+  nVolumeID As Long
+  sBook As String
+  nBookID As Long
+  
+  rContract As Word.Range
+  rCustomer As Word.Range
+  rTheme As Word.Range
+End Type
+
+' Ïîëîæåíèÿ ðàçäåëîâ
+Public Type SectionHeader
+  rFind As Word.Range
+  nStart As Long
+  nFinish As Long
+  cText As Long
+  cHeader As Long
+End Type
+
+Public Type SectionData
+  sName As String
+  sChapter As String
+  bNewChapter As Boolean
+End Type
+
+Public Function DesignTheme(ThemeColorIndex As WdThemeColorIndex) As Long
+  Select Case ThemeColorIndex:
+    Case wdThemeColorMainDark1:     DesignTheme = Format("&HD000FFFF")
+    Case wdThemeColorMainLight1:    DesignTheme = Format("&HD100FFFF")
+    Case wdThemeColorMainDark2:     DesignTheme = Format("&HD200FFFF")
+    Case wdThemeColorMainLight2:    DesignTheme = Format("&HD300FFFF")
+    Case wdThemeColorAccent1:       DesignTheme = Format("&HD400FFFF")
+    Case wdThemeColorAccent2:       DesignTheme = Format("&HD500FFFF")
+    Case wdThemeColorAccent3:       DesignTheme = Format("&HD600FFFF")
+    Case wdThemeColorAccent4:       DesignTheme = Format("&HD700FFFF")
+    Case wdThemeColorAccent5:       DesignTheme = Format("&HD800FFFF")
+    Case wdThemeColorAccent6:       DesignTheme = Format("&HD900FFFF")
+    Case wdThemeColorHyperlink:     DesignTheme = Format("&HDA00FFFF")
+    Case wdThemeColorHyperlinkFollowed: DesignTheme = Format("&HDB00FFFF")
+    Case wdThemeColorBackground1:     DesignTheme = Format("&HDC00FFFF")
+    Case wdThemeColorText1:       DesignTheme = Format("&HDD00FFFF")
+    Case wdThemeColorBackground2:     DesignTheme = Format("&HDE00FFFF")
+    Case wdThemeColorText2:       DesignTheme = Format("&HDF00FFFF")
+    Case Else:
+  End Select
+End Function
+

src/DevHelper.bas

@@ -0,0 +1,21 @@
+Attribute VB_Name = "DevHelper"
+Option Private Module
+Option Explicit
+
+Public Function Dev_PrepareSkeleton()
+  ' Do nothing
+End Function
+
+Public Function Dev_ManualRunTest()
+  Dim sSuite$: sSuite = "s_UndoWrapper"
+  Dim sTest$: sTest = "t_BasicUndo"
+  Dim sMsg$: sMsg = Dev_RunTestDebug(sSuite, sTest)
+  Debug.Print sMsg
+  Call MsgBox(sMsg)
+End Function
+
+Public Function Dev_GetTestSuite(sName$) As Object
+  Select Case sName
+ '   Case "s_TextEdit": Set Dev_GetTestSuite = New s_TextEdit
+  End Select
+End Function

src/IconPicker.cls

@@ -0,0 +1,35 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "IconPicker"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+Option Explicit
+
+Private m_Form As CDD_AddPict
+Private WithEvents m_Picto As MSForms.Label
+Attribute m_Picto.VB_VarHelpID = -1
+Private WithEvents m_Name As MSForms.Label
+Attribute m_Name.VB_VarHelpID = -1
+
+Public Sub AssignControls(crtForm As CDD_AddPict, topLbl As MSForms.Label, nmeLbl As MSForms.Label)
+  Set m_Form = crtForm
+  Set m_Picto = topLbl
+  Set m_Name = nmeLbl
+End Sub
+
+Private Sub m_Name_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
+  execPicto
+End Sub
+
+Private Sub m_Picto_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
+  execPicto
+End Sub
+
+Private Sub execPicto()
+  m_Form.Choice = m_Picto
+  m_Form.Hide
+End Sub

src/InfoDocument.cls

@@ -0,0 +1,68 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "InfoDocument"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+Option Explicit
+
+Public volume_ As String
+Public volumeNo_ As Long
+Public book_ As String
+Public bookNo_ As Long
+Public document_ As String
+
+Public Function Init(theDoc As Word.Document)
+  document_ = theDoc.Name
+  document_ = Left(document_, IIf(InStr(document_, ".") - 1 < 0, 0, InStr(document_, ".") - 1))
+  
+  Dim rFind As Word.Range
+  Set rFind = theDoc.Sections(1).Range
+  With rFind.Find
+    .Text = "Êíèãà "
+    .Format = True
+    .MatchCase = False
+    ' .Style = "ß_Òèòóë Íàçâàíèå êíèãè"
+  End With
+  If rFind.Find.Execute Then
+    Set rFind = rFind.Next(wdWord, 1)
+    bookNo_ = CLng(rFind.Text)
+    
+    Call rFind.MoveEndUntil(CSET_SLETTERS & CSET_BLETTERS, wdForward)
+    rFind.Start = rFind.End
+    Call rFind.MoveEndUntil(Chr(13), wdForward)
+    book_ = rFind
+  End If
+  
+  Set rFind = theDoc.Sections(1).Range
+  With rFind.Find
+    .Text = "Òîì "
+    .Format = True
+    .MatchCase = False
+    ' .Style = "ß_Òèòóë Íàçâàíèå Òîìà"
+  End With
+  If rFind.Find.Execute Then
+    Set rFind = rFind.Next(wdWord, 1)
+    volumeNo_ = CLng(rFind.Text)
+    
+    Call rFind.MoveEndUntil(CSET_SLETTERS & CSET_BLETTERS, wdForward)
+    rFind.Start = rFind.End
+    Call rFind.MoveEndUntil(Chr(13))
+    volume_ = rFind
+  End If
+End Function
+
+Public Function IsValidNames() As Boolean
+  IsValidNames = volume_ <> "" And book_ <> ""
+End Function
+
+Public Property Get BookText() As String
+  BookText = "Êíèãà " & Trim(Str(bookNo_)) & ". " & book_
+End Property
+
+Public Property Get VolumeText() As String
+  VolumeText = "Òîì " & Trim(Str(volumeNo_)) & ". " & volume_
+End Property

src/ItemChapter.cls

@@ -0,0 +1,22 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "ItemChapter"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+Option Explicit
+
+Public start_ As Long
+Public finish_ As Long
+Public text_ As String
+
+Public Function Clone() As ItemChapter
+  Dim aClone As New ItemChapter
+  aClone.start_ = start_
+  aClone.finish_ = finish_
+  aClone.text_ = text_
+  Set Clone = aClone
+End Function

src/ItemColontitles.cls

@@ -0,0 +1,23 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "ItemColontitles"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+Option Explicit
+
+Public start_ As Long
+Public finish_ As Long
+
+Public doTopLeft As Boolean
+Public doTopRight As Boolean
+Public doBottomLeft As Boolean
+Public doBottomRight As Boolean
+
+Public mTopLeft As TSource
+Public mTopRight As TSource
+Public mBottomLeft As TSource
+Public mBottomRight As TSource

src/ItemFontScale.cls

@@ -0,0 +1,24 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "ItemFontScale"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+Option Explicit
+
+Public lineSpacing_ As Double
+Public fontMultiplier_ As Double
+Public textSize_ As Double
+Public spacing_ As Double
+Public fontFactor_ As Double
+
+Private Sub Class_Initialize()
+  lineSpacing_ = -1
+  fontMultiplier_ = 1
+  textSize_ = 11
+  spacing_ = 1
+  fontFactor_ = 1.15
+End Sub

src/Main.bas

@@ -0,0 +1,334 @@
+Attribute VB_Name = "Main"
+Option Explicit
+
+Public Sub CDA_AutoDesign()
+  Call CDD_AutoDesign.Show
+  If Not CDD_AutoDesign.isCancelled_ Then _
+    Call RunAutoDesign(CDD_AutoDesign.Preferences)
+    
+  Call Unload(CDD_AutoDesign)
+  Call UserInteraction.ShowMessage(IM_AUTODESIGN_OK)
+End Sub
+
+Public Sub CDA_FixLines()
+  Dim theDoc As Word.Document:  Set theDoc = ActiveDocument
+  
+  Call CSE_ProgressBar.Init("Áàëàíñèðîâàíèå", "Âûðàâíèâàíèå çàãîëîâêîâ...", maxVal:=3)
+  Call CSE_ProgressBar.ShowModeless
+  
+  ' Ôèêñèì çàãîëîâêè òàê, ÷òîáû âûïîëíÿëîñü âûðàâíèâàíèå
+  Call UpdateListsLayout(theDoc)
+  Call CSE_ProgressBar.IncrementA
+  
+  Call UpdateTextLayout(theDoc)
+  Call CSE_ProgressBar.IncrementA
+  
+  ' Ôèêñèì êàðòèíêè è âûíîñêè
+  Call UpdateObjectFields(theDoc)
+  Call CSE_ProgressBar.IncrementA
+  
+  Call Unload(CSE_ProgressBar)
+  Call UserInteraction.ShowMessage(IM_FIX_LINES_OK)
+End Sub
+
+Public Sub CDA_Repaint()
+  Dim theDoc As Word.Document: Set theDoc = ActiveDocument
+  
+  Call CDD_Paint.Init
+  Call CDD_Paint.Show
+  If CDD_Paint.isCancelled_ Then _
+    Exit Sub
+  
+  Dim wordUI As New API_WordWrapper: Call wordUI.SetDocument(theDoc)
+  Call wordUI.PauseUI
+  
+  Call CSE_ProgressBar.Init("Ïîêðàñêà", maxVal:=CDD_Paint.Count)
+  Call CSE_ProgressBar.ShowModeless
+  
+  If CDD_Paint.DoText Then
+    Call RepaintText(theDoc)
+    Call CSE_ProgressBar.IncrementA
+  End If
+  
+  If CDD_Paint.DoFields Then
+    Call RepaintTextShapes(theDoc)
+    Call CSE_ProgressBar.IncrementA
+  End If
+  
+  If CDD_Paint.DoToC Then
+    Call RepaintToC(theDoc)
+    Call CSE_ProgressBar.IncrementA
+  End If
+  
+  If CDD_Paint.DoLinks Then
+    Call RepaintHLinks(theDoc)
+    Call CSE_ProgressBar.IncrementA
+  End If
+  
+  Call Unload(CSE_ProgressBar)
+  Call wordUI.ResumeUI
+  Call UserInteraction.ShowMessage(IM_REPAINT_OK)
+End Sub
+
+Public Sub CDA_FooterHeader()
+  Dim theDoc As Word.Document: Set theDoc = ActiveDocument
+  Dim docMeta As New InfoDocument: Call docMeta.Init(theDoc)
+
+  Call CDD_HeaderFooter.Init(theDoc, docMeta.IsValidNames)
+  Call CDD_HeaderFooter.Show
+  If CDD_HeaderFooter.isCancelled_ Then _
+    Exit Sub
+    
+  Dim props As ItemColontitles: Set props = CDD_HeaderFooter.Data
+  Call Unload(CDD_HeaderFooter)
+  
+  Call CSE_ProgressBar.Init("Îôîðìëåíèå êîëîíòèòóëîâ", sHeader:="Çàïîëíåíèå...", maxVal:=props.finish_ - props.start_ + 1)
+  Call CSE_ProgressBar.ShowModeless
+  
+  Call CreateColontitles(theDoc, docMeta, props, "IncrementA")
+  
+  Call Unload(CSE_ProgressBar)
+  Call UserInteraction.ShowMessage(IM_FOOTER_OK)
+End Sub
+
+Public Sub CDA_InsertBreak()
+  Dim theDoc As Word.Document:  Set theDoc = ActiveDocument
+  Dim theRange As Word.Range:  Set theRange = theDoc.ActiveWindow.Selection.Range
+  If Selection.Range.Start = Selection.Range.End Then
+    Set theRange = Selection.Paragraphs(1).Range
+  End If
+  
+  Call InsertOneColomnSection(theRange)
+End Sub
+
+Public Sub CDA_InsertHeader()
+  Dim theDoc As Word.Document:  Set theDoc = ActiveDocument
+  
+  Dim sHeader$: sHeader = UserInteraction.PromptInput("Ââåäèòå òåêñò çàãîëîâêà")
+  If sHeader = vbNullString Then _
+    Exit Sub
+  Dim nLevel&: nLevel = Int(UserInteraction.PromptInput("Ââåäèòå óðîâåíü çàãîëîâêà"))
+  If nLevel < 2 And nLevel > 5 Then _
+    Exit Sub
+  
+  Dim theRange As Word.Range: Set theRange = theDoc.ActiveWindow.Selection.Range
+  If theRange.Paragraphs.Count < 2 Then
+    Set theRange = theRange.Paragraphs(1).Range
+  End If
+  
+  Call InsertHeader(theRange, sHeader, nLevel)
+End Sub
+
+Public Sub CDA_UpdateToC()
+  Dim theDoc As Word.Document:  Set theDoc = ActiveDocument
+  
+  Dim wordUI As New API_WordWrapper: Call wordUI.SetDocument(theDoc)
+  Call wordUI.PauseUI
+  
+  Dim toc As Word.TableOfContents
+  For Each toc In theDoc.TablesOfContents
+    Call UpdateTableOfContents(toc)
+    Call RepaintToC(toc)
+  Next toc
+  
+  Call wordUI.ResumeUI
+End Sub
+
+Public Sub CDA_TSAlign()
+  If ActiveDocument.ActiveWindow.Selection.Tables.Count <> 1 Then
+    Call UserInteraction.ShowMessage(EM_TABLE_NOT_SELECTED)
+    Exit Sub
+  End If
+  Call PrepareTableForSplit(ActiveDocument.ActiveWindow.Selection.Tables(1))
+End Sub
+
+Public Sub CDA_TSSlice()
+  If ActiveDocument.ActiveWindow.Selection.Tables.Count <> 1 Then
+    Call UserInteraction.ShowMessage(EM_TABLE_NOT_SELECTED)
+    Exit Sub
+  End If
+  
+  Dim target As Word.Table: Set target = ActiveDocument.ActiveWindow.Selection.Tables(1)
+  If target.Rows(1).Cells.Count = 0 Then
+    Call UserInteraction.ShowMessage(EM_TABLE_MERGED_CELLS)
+    Exit Sub
+  End If
+  
+  Call RemoveSplitMarkerFrom(target)
+  ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitFullPage
+  target.Rows.AllowBreakAcrossPages = False
+
+  Call CSE_ProgressBar.Init("Íàðåçêà òàáëèöû", maxVal:=2)
+  Call CSE_ProgressBar.ShowModeless
+  
+  Dim wordUI As New API_WordWrapper: Call wordUI.SetDocument(ActiveDocument)
+  Call wordUI.PauseUI
+  
+  CSE_ProgressBar.Description = "Ïîäãîòîâêà ôðàãìåíòîâ..."
+  Dim slices As New Collection: Set slices = SliceTable(target)
+  Call CSE_ProgressBar.IncrementA
+  
+  CSE_ProgressBar.Description = "Ðàçäåëåíèå òàáëèöû..."
+  Call SplitSlices(slices)
+  Call CSE_ProgressBar.IncrementA
+  
+  With ActiveWindow.ActivePane.View.Zoom
+    .PageColumns = 2
+    .PageRows = 1
+  End With
+  
+  Call wordUI.ResumeUI
+  Call Unload(CSE_ProgressBar)
+End Sub
+
+Public Sub CDA_TSPaint()
+' Ïîêðàñêà òàáëèöû ÷åðåç ïðîòîòèï
+  Dim theDoc As Word.Document:  Set theDoc = ActiveDocument
+  Dim target As Word.Range: Set target = theDoc.Application.Selection.Range
+  If target.Tables.Count < 1 Then
+    Call UserInteraction.ShowMessage(EM_TABLE_NOT_SELECTED)
+    Exit Sub
+  End If
+  
+  Call CDD_TablePrototype.Init(theDoc.Tables.Count)
+  Call CDD_TablePrototype.Show
+  If CDD_TablePrototype.isCancelled_ Then _
+    Exit Sub
+    
+  Dim nPrototype&: nPrototype = CDD_TablePrototype.GetPickedID
+  Dim applyToAll As Boolean: applyToAll = CDD_TablePrototype.applyToAll
+  Call Unload(CDD_TablePrototype)
+  
+  If nPrototype = 0 Then _
+    Exit Sub
+    
+  Call RunPaintTableProto(target, IIf(applyToAll, target.Tables.Count, 1), theDoc.Tables(nPrototype))
+  Call UserInteraction.ShowMessage(IM_REPAINT_OK)
+End Sub
+
+Public Sub CDA_PaintTable()
+  Dim theDoc As Word.Document: Set theDoc = ActiveDocument
+  Dim rSelection As Word.Range: Set rSelection = theDoc.Application.Selection.Range
+  Dim tableCount&: tableCount = rSelection.Tables.Count
+  If rSelection.Tables.Count < 1 Then
+    Call UserInteraction.ShowMessage(EM_TABLE_NOT_SELECTED)
+    Exit Sub
+  End If
+  
+  Dim headRange As Word.Range: Set headRange = GetSectionHeader(rSelection.Start, theDoc)
+  If headRange Is Nothing Then
+    Call UserInteraction.ShowMessage(EM_TABLE_OUTSIDE_SECTION)
+    Exit Sub
+  End If
+  
+  Call CDD_TableColors.Init(ColorGetRGB(headRange.Font.Color, theDoc))
+  Call CDD_TableColors.Show
+  If CDD_TableColors.isCancelled_ Then _
+    Exit Sub
+  Dim props As TablePaintProps: props = CDD_TableColors.TableProperties
+  Call Unload(CDD_TableColors)
+  
+  Call RunPaintTable(rSelection, tableCount, props)
+  
+  Call UserInteraction.ShowMessage(IM_REPAINT_OK)
+End Sub
+
+Public Sub CDA_InlineFields()
+  Dim theDoc As Word.Document: Set theDoc = ActiveDocument
+  Dim aField As Word.Field
+  For Each aField In theDoc.Fields
+    If aField.Type = wdFieldRef Then
+      aField.Copy
+      Call aField.Select
+      Call theDoc.Application.Selection.Range.PasteAndFormat(wdFormatPlainText)
+    End If
+  Next aField
+End Sub
+
+Public Sub CDA_InsertObject()
+  Dim target As Word.Range: Set target = ActiveDocument.ActiveWindow.Selection.Range.Paragraphs.First.Range
+  Call CDD_AddPict.Show
+  Select Case CDD_AddPict.Flag
+    Case 0: Call InsertConceptSymbol(target, CDD_AddPict.Choice)
+    Case 1: Call InsertPictureRef(target, CDD_AddPict.Bookmark)
+    Case 2: Call InsertNewPicture(CDD_AddPict.PicAdd, target)
+    Case 3: Call InsertTextField(target, CDD_AddPict.LighterText)
+  End Select
+End Sub
+
+Public Sub CDA_InlineObjects()
+  Dim target As Word.Range: Set target = ActiveDocument.ActiveWindow.Selection.Paragraphs.First.Range.Duplicate
+  Dim nShape&
+  For nShape = 1 To target.InlineShapes.Count Step 1
+    Call InlineAsPNG(target.InlineShapes(nShape))
+  Next nShape
+End Sub
+
+Public Sub CDA_CreateBlocking()
+  Dim target As Word.Range: Set target = ActiveDocument.ActiveWindow.Selection.Range
+  If target.Start = target.End Then _
+    Exit Sub
+  Call CreateLayoutBlock(target)
+End Sub
+
+Public Sub CDA_ScaleFont()
+  Dim theDoc As Word.Document: Set theDoc = ActiveDocument
+  
+  Call CDD_FontScaling.Init
+  Call CDD_FontScaling.Show
+  
+  If Not CDD_FontScaling.isCancelled_ Then _
+    Call ExecuteRedesign(theDoc, CDD_FontScaling.SumUp)
+  
+  Call Unload(CDD_FontScaling)
+End Sub
+
+Public Sub CDA_Help()
+  MsgBox "TODO"
+End Sub
+
+' =======
+Private Function RunPaintTableProto(target As Word.Range, tableCount&, proto As Word.Table)
+  Call CSE_ProgressBar.Init("Ïîêðàñêà òàáëèö", sHeader:="Ðàáîòàåì...", maxVal:=tableCount, canInterrupt:=True)
+  Call CSE_ProgressBar.ShowModeless
+  
+  Dim nTable&
+  For nTable = 1 To tableCount Step 1
+    Dim aTable As Word.Table: Set aTable = target.Tables(nTable)
+    If aTable.Range.Start = proto.Range.Start Then _
+      GoTo NEXT_TABLE
+      
+    Call PaintTableProto(aTable, proto)
+    
+NEXT_TABLE:
+    Call CSE_ProgressBar.IncrementA
+    If CSE_ProgressBar.Interrupted Then _
+      nTable = tableCount
+  Next nTable
+
+  Call Unload(CSE_ProgressBar)
+End Function
+
+Private Function RunPaintTable(target As Word.Range, tableCount&, props As TablePaintProps)
+  Dim tablCount&: tablCount = Selection.Tables.Count
+  
+  Call CSE_ProgressBar.Init("Ïîêðàñêà òàáëèö", sHeader:="Èçìåíåíèå ïàðàìåòðîâ òàáëèö...", maxVal:=tablCount, canInterrupt:=True)
+  Call CSE_ProgressBar.ShowModeless
+  
+  Dim nTable&
+  For nTable = 1 To tableCount Step 1
+    Dim aTable As Word.Table: Set aTable = target.Tables(nTable)
+    Dim headRange As Word.Range: Set headRange = GetSectionHeader(aTable.Range.Start, target.Document)
+    If headRange Is Nothing Then _
+      GoTo NEXT_TABLE
+      
+    Call PaintTable(aTable, headRange.Font.Color, props)
+    
+NEXT_TABLE:
+    Call CSE_ProgressBar.IncrementA
+    If CSE_ProgressBar.Interrupted Then _
+      nTable = tableCount
+  Next nTable
+  
+  Call Unload(CSE_ProgressBar)
+End Function

src/MainImpl.bas

@@ -0,0 +1,6 @@
+Attribute VB_Name = "MainImpl"
+Option Explicit
+
+
+' =============
+

src/dialogs/CDD_AddPict.frm

@@ -0,0 +1,152 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CDD_AddPict 
+   Caption         =   "Âñòàâêà îáúåêòà íà ïîëå"
+   ClientHeight    =   7530
+   ClientLeft      =   120
+   ClientTop       =   465
+   ClientWidth     =   10155
+   OleObjectBlob   =   "CDD_AddPict.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "CDD_AddPict"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Option Explicit
+
+' TODO: isCancelled_ and extract logic
+
+Private m_NewPict As String
+Private m_chsnSymb As String
+Private m_icnCells As Collection
+
+Private Const INIT_POS_BG As Integer = 0
+Private Const INIT_POS_BK As Integer = -90
+Private Const INIT_POS_G As Integer = 12
+
+Public Property Get Flag() As Integer
+  Flag = Selector.Value
+End Property
+
+Public Property Get Bookmark() As String
+  Bookmark = Me.ListBox.Value
+End Property
+
+Public Property Get LighterText() As String
+  LighterText = LighterBox.Text
+End Property
+
+Public Property Get PicAdd() As String
+  PicAdd = m_NewPict
+End Property
+
+Public Property Get Choice() As String
+  Choice = m_chsnSymb
+End Property
+
+Public Property Let Choice(retVal$)
+  m_chsnSymb = retVal
+End Property
+
+Private Sub CmdADD_Click()
+  Me.Hide
+End Sub
+
+Private Sub cmdAddEx_Click()
+  Me.Hide
+End Sub
+
+Private Sub CmdLighter_Click()
+  Me.Hide
+End Sub
+
+Private Sub ListBox_Change()
+  Dim tmp As Word.Range:  Set tmp = Selection.Range
+  Dim oper As Word.InlineShape:   Set oper = ActiveDocument.Bookmarks(ListBox.Value).Range.InlineShapes(1)
+  Dim x As Double, y As Double, bln As Boolean
+  With oper
+    x = oper.Height
+    y = oper.Width
+    bln = Application.ScreenUpdating
+    Application.ScreenUpdating = False
+    oper.Height = CentimetersToPoints(6) * x / y
+    oper.Width = CentimetersToPoints(6)
+    Call oper.Select
+    Call Selection.CopyAsPicture
+    oper.Height = x
+    oper.Width = y
+    Application.ScreenUpdating = bln
+  End With
+  Set Me.PrevEx.Picture = PastePicture(xlBitmap)
+  Call tmp.Select
+End Sub
+
+Private Sub ListBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
+  If ListBox.ListIndex <> -1 Then Me.Hide
+End Sub
+
+Private Sub Srch_Click()
+  m_NewPict = UserInteraction.PromptFile("")
+  Set PrevNew.Picture = LoadPictureGDI(m_NewPict)
+  Me.AddressBox.Text = m_NewPict
+End Sub
+
+Private Sub UserForm_Initialize()
+  Selector.Value = 0
+  Set m_icnCells = New Collection
+  Call LabelsFill
+  Call ListFill
+End Sub
+
+Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
+  End
+End Sub
+
+Private Function ListFill()
+  Dim curDoc As Word.Document:  Set curDoc = ActiveDocument
+  Call Me.ListBox.Clear
+  
+  Dim tmpMrk As Word.Bookmark
+  For Each tmpMrk In curDoc.Bookmarks
+    If Left(tmpMrk.Name, 5) = "pict_" Then _
+      Me.ListBox.AddItem (tmpMrk.Name)
+  Next tmpMrk
+End Function
+
+Private Function LabelsFill()
+  Dim i%
+  Dim tmpCell As IconPicker
+  Dim tmpTop As MSForms.Label
+  Dim tmpNme As MSForms.Label
+  
+  For i = 1 To 250
+    On Error Resume Next
+    
+    Set tmpTop = Me.FramePict.Controls("Label" & 2 * i - 1)
+    If tmpTop.Parent.Parent.Name <> Selector.Pages.Item(0).Name Then GoTo SKP_NCELL
+    Set tmpNme = Me.FramePict.Controls("Label" & 2 * i)
+    If tmpNme.Parent.Parent.Name <> Selector.Pages.Item(0).Name Then GoTo SKP_NCELL
+    If Err.Number <> 0 Then GoTo SKP_NCELL
+    
+    Select Case i
+      Case Is <= 50:  tmpTop.Caption = chrW(96 + i)
+      Case Is <= 100: tmpTop.Caption = chrW(64 + i - 50)
+      Case Is <= 150:
+        tmpTop.Font.Charset = 204
+        tmpTop.Caption = chrW(val("&H" & 429 + i - 100)) '!!! ÏÎÌÅÍßÒÜ ÄÈÀÏÀÇÎÍ
+      Case Is <= 200: tmpTop.Caption = chrW(val("&H" & 250 + i - 150))
+      Case Is <= 250: tmpTop.Caption = chrW(val("&H" & 530 + i - 200))
+    End Select
+    
+    tmpTop.Font.Name = "conceptpict"
+    
+    Set tmpCell = New IconPicker
+    Call tmpCell.AssignControls(Me, tmpTop, tmpNme)
+    Call m_icnCells.Add(tmpCell)
+    
+SKP_NCELL:
+    Err.Clear
+  Next i
+  On Error GoTo 0
+End Function

src/dialogs/CDD_AutoDesign.frm

@@ -0,0 +1,41 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CDD_AutoDesign 
+   Caption         =   "Ïàðàìåòðû àâòîìàêåòèðîâàíèÿ"
+   ClientHeight    =   3180
+   ClientLeft      =   120
+   ClientTop       =   465
+   ClientWidth     =   3585
+   OleObjectBlob   =   "CDD_AutoDesign.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "CDD_AutoDesign"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Option Explicit
+
+Public isCancelled_ As Boolean
+
+Private Sub UserForm_Initialize()
+  isCancelled_ = True
+End Sub
+
+Public Function Init()
+  isCancelled_ = True
+End Function
+
+Private Sub cmdAutoDesing_Click()
+  isCancelled_ = False
+  Me.Hide
+End Sub
+
+Public Property Get Preferences() As AutoDesignOptions
+  Preferences.reapplyLists = Me.ckReStyleNum.Value
+  Preferences.fixObjects = Me.ckInline.Value
+  Preferences.doLayout = Me.ckAlign.Value
+  Preferences.generateColontitles = Me.ckColont.Value
+  Preferences.titlePage = Me.ckTitle.Value
+  Preferences.Count = Abs(Me.ckInline.Value + Me.ckAlign.Value _
+              + Me.ckColont.Value + Me.ckTitle.Value + Me.ckReStyleNum.Value)
+End Property

src/dialogs/CDD_FontScaling.frm

@@ -0,0 +1,75 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CDD_FontScaling 
+   Caption         =   "Èçìåíåíèå øðèôòîâ"
+   ClientHeight    =   2385
+   ClientLeft      =   120
+   ClientTop       =   465
+   ClientWidth     =   6360
+   OleObjectBlob   =   "CDD_FontScaling.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "CDD_FontScaling"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Option Explicit
+
+Private Const m_BaseSize As Double = 11
+Private Const m_BaseInter As Double = 1
+
+Dim m_nSize As Double
+Dim m_Inter As Double
+Dim m_FontScale As Double
+
+Public isCancelled_ As Boolean
+
+Private Sub UserForm_Initialize()
+  isCancelled_ = True
+  Call Me.FontList.Clear
+  Call Me.FontList.AddItem("Times New Roman")
+  Me.FontList.Value = FontList.List(0)
+End Sub
+
+Public Function Init()
+  isCancelled_ = True
+End Function
+
+Private Sub cmdLonely_Click()
+  isCancelled_ = False
+  Me.Hide
+End Sub
+
+Private Sub FontList_Change()
+  Call Update
+End Sub
+
+Private Sub InterSpin_Change()
+  Call Update
+End Sub
+
+Private Sub SizeSpin_Change()
+  Call Update
+End Sub
+
+Private Function Update()
+  m_nSize = m_BaseSize + Me.SizeSpin.Value / 2
+  m_Inter = m_BaseInter + Me.InterSpin.Value / 20
+  
+  Me.NewLbl.Font.Size = m_nSize
+  Me.tbNSize.Text = m_nSize
+  Me.interSize = m_Inter
+  
+  Select Case Me.FontList.Value
+    Case "Times New Roman":     m_FontScale = 1.15
+  End Select
+End Function
+
+Public Function SumUp() As ItemFontScale
+  Set SumUp = New ItemFontScale
+  SumUp.fontMultiplier_ = m_nSize / m_BaseSize
+  SumUp.lineSpacing_ = m_nSize * m_FontScale * m_Inter
+  SumUp.fontFactor_ = m_FontScale
+  SumUp.spacing_ = m_Inter
+  SumUp.textSize_ = m_nSize
+End Function

src/dialogs/CDD_HeaderFooter.frm

@@ -0,0 +1,103 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CDD_HeaderFooter 
+   Caption         =   "Îïðåäåëèòå ñîäåðæàíèå êîëîíòèòóëîâ"
+   ClientHeight    =   6645
+   ClientLeft      =   120
+   ClientTop       =   465
+   ClientWidth     =   6375
+   OleObjectBlob   =   "CDD_HeaderFooter.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "CDD_HeaderFooter"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Option Explicit
+
+Public isCancelled_ As Boolean
+
+Private Sub UserForm_Initialize()
+  isCancelled_ = True
+End Sub
+
+Public Function Init(target As Word.Document, doCreds As Boolean)
+  isCancelled_ = True
+  
+  TextBegin.Value = 3
+  TextEnd.Value = target.Sections.Count - 1
+  
+  Call FillCombo(ComboLU, doCreds)
+  Call FillCombo(ComboRU, doCreds)
+  Call FillCombo(ComboLD, doCreds)
+  Call FillCombo(ComboRD, doCreds)
+  
+  ComboLU.Value = IIf(doCreds, "Òîì", ComboLU.List(0))
+  ComboRU.Value = IIf(doCreds, "Êíèãà", ComboRU.List(0))
+  ComboLD.Value = "ÊÎÍÖÅÏÒ"
+  ComboRD.Value = "Ðàçäåë"
+End Function
+
+Private Sub ButtCancel_Click()
+  isCancelled_ = True
+  Call Me.Hide
+End Sub
+
+Private Sub ButtFix_Click()
+  isCancelled_ = False
+  Me.Hide
+End Sub
+
+Private Sub TextBoxEnd_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
+  If KeyAscii < 48 Or KeyAscii > 57 Then KeyAscii = 0
+End Sub
+
+Private Sub TextBoxBegin_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
+  If KeyAscii < 48 Or KeyAscii > 57 Then KeyAscii = 0
+End Sub
+
+Private Function FillCombo(cmbBox As control, doCreds As Boolean)
+  With cmbBox
+    Call .Clear
+    If cmbBox.Name = "ComboLU" Or cmbBox.Name = "ComboRU" Then
+      If doCreds Then
+        Call .AddItem("Òîì")
+        Call .AddItem("Êíèãà")
+      End If
+      Call .AddItem("Ãëàâà")
+    End If
+    
+    Call .AddItem("Äîêóìåíò")
+    Call .AddItem("Ðàçäåë")
+    Call .AddItem("ÊÎÍÖÅÏÒ")
+  End With
+End Function
+
+Private Function TextToType(aText$) As TSource
+  Select Case aText
+  Case "Êíèãà": TextToType = T_SOURCE_BOOK
+  Case "Òîì": TextToType = T_SOURCE_VOLUME
+  Case "Äîêóìåíò": TextToType = T_SOURCE_DOCUMENT
+  Case "Ðàçäåë": TextToType = T_SOURCE_SECTION
+  Case "Ãëàâà":  TextToType = T_SOURCE_CHAPTER
+  Case "ÊÎÍÖÅÏÒ": TextToType = T_SOURCE_CONCEPT
+  End Select
+End Function
+
+Public Property Get Data() As ItemColontitles
+  Set Data = New ItemColontitles
+  With Data
+    .mTopLeft = TextToType(ComboLU.Value)
+    .mTopRight = TextToType(ComboRU.Value)
+    .mBottomLeft = TextToType(ComboLD.Value)
+    .mBottomRight = TextToType(ComboRD.Value)
+    
+    .doTopLeft = ckLU.Value
+    .doTopRight = ckLD.Value
+    .doBottomLeft = ckRU.Value
+    .doBottomRight = ckRD.Value
+    
+    .start_ = CLng(TextBegin.Value)
+    .finish_ = CLng(TextEnd.Value)
+  End With
+End Property

src/dialogs/CDD_Paint.frm

@@ -0,0 +1,51 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CDD_Paint 
+   Caption         =   "Ïîêðàñêà"
+   ClientHeight    =   2760
+   ClientLeft      =   120
+   ClientTop       =   465
+   ClientWidth     =   2610
+   OleObjectBlob   =   "CDD_Paint.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "CDD_Paint"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Option Explicit
+
+Public isCancelled_ As Boolean
+
+Private Sub UserForm_Initialize()
+  isCancelled_ = True
+End Sub
+
+Public Function Init()
+  isCancelled_ = True
+End Function
+
+Public Property Get DoText() As Boolean
+  DoText = cbPart.Value
+End Property
+
+Public Property Get DoLinks() As Boolean
+  DoLinks = cbHLs.Value
+End Property
+
+Public Property Get DoFields() As Boolean
+  DoFields = cbOuts.Value
+End Property
+
+Public Property Get DoToC() As Boolean
+  DoToC = cbCont.Value
+End Property
+
+Public Property Get Count() As Long
+  Count = DoToC + DoText + DoLinks + DoFields
+End Property
+
+Private Sub btOk_Click()
+  isCancelled_ = False
+  Me.Hide
+End Sub

src/dialogs/CDD_RunAudit.frm

@@ -0,0 +1,62 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CDD_RunAudit 
+   Caption         =   "Îòìåòèòü â òåêñòå"
+   ClientHeight    =   3720
+   ClientLeft      =   120
+   ClientTop       =   465
+   ClientWidth     =   3060
+   OleObjectBlob   =   "CDD_RunAudit.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "CDD_RunAudit"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Option Explicit
+
+Public isCancelled_ As Boolean
+
+Private Sub UserForm_Initialize()
+  isCancelled_ = True
+End Sub
+
+Public Function Init()
+  isCancelled_ = True
+End Function
+
+Private Sub rGo_Click()
+  isCancelled_ = False
+  Me.Hide
+End Sub
+
+Public Property Get DoHeaders() As Boolean
+  DoHeaders = r1.Value
+End Property
+
+Public Property Get DoPar() As Boolean
+  DoPar = r2.Value
+End Property
+
+Public Property Get DoDash() As Boolean
+  DoDash = r3.Value
+End Property
+
+Public Property Get DoFields() As Boolean
+  DoFields = r4.Value
+End Property
+
+Public Property Get DoListNums() As Boolean
+  DoListNums = r5.Value
+End Property
+
+Public Property Get DoPict() As Boolean
+  DoPict = r6.Value
+End Property
+
+Public Property Get CountRules() As Integer
+  Dim i&
+  For i = 1 To 6
+    CountRules = CountRules + IIf(Me.Controls("r" & i).Value, 1, 0)
+  Next i
+End Property

src/dialogs/CDD_TableColors.frm

@@ -0,0 +1,128 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CDD_TableColors 
+   Caption         =   "Óñòàíîâèòå íàñòðîéêè òàáëèö"
+   ClientHeight    =   3945
+   ClientLeft      =   120
+   ClientTop       =   465
+   ClientWidth     =   7935
+   OleObjectBlob   =   "CDD_TableColors.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "CDD_TableColors"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Option Explicit
+
+Private eventsOn_ As Boolean
+
+Private props_ As TablePaintProps
+
+Public isCancelled_ As Boolean
+
+Private Sub UserForm_Initialize()
+  isCancelled_ = True
+End Sub
+
+Public Function Init(theColor&)
+  eventsOn_ = True
+  isCancelled_ = True
+  
+  props_.sectionColor = theColor
+  props_.cGrid = 1000 * -0.35
+  props_.cHeading = 1000 * 0.2
+  props_.cSubHead = 1000 * 0.35
+  props_.cZebra = 1000 * 0.8
+  
+  ltp.BackColor = theColor
+  
+  Call UpdateFM
+End Function
+
+Public Property Get TableProperties() As TablePaintProps
+  TableProperties = props_
+End Property
+
+Private Function UpdateFM()
+  eventsOn_ = False
+  bodB.Value = props_.cGrid
+  headB.Value = props_.cHeading
+  subB.Value = props_.cSubHead
+  zerB.Value = props_.cZebra
+  
+  LS.BackColor = ColorAdjustLuma(props_.sectionColor, props_.cSubHead, True)
+  LH.BackColor = ColorAdjustLuma(props_.sectionColor, props_.cHeading, True)
+  LZ.BackColor = ColorAdjustLuma(props_.sectionColor, props_.cZebra, True)
+  LF.BackColor = ColorAdjustLuma(props_.sectionColor, props_.cGrid, True)
+  
+  Dim greyCol&
+  
+  lf1.BackColor = LF.BackColor
+  ls1.BackColor = LS.BackColor
+  lh1.BackColor = LH.BackColor
+  lh2.BackColor = LH.BackColor
+     
+  greyCol = ColorGetLuma(LZ.BackColor)
+  l2.BackColor = IIf(greyCol < 127, RGB(255, 255, 255), RGB(0, 0, 0))
+  l4.BackColor = IIf(greyCol < 127, RGB(255, 255, 255), RGB(0, 0, 0))
+  l6.BackColor = IIf(greyCol < 127, RGB(255, 255, 255), RGB(0, 0, 0))
+  l8.BackColor = IIf(greyCol < 127, RGB(255, 255, 255), RGB(0, 0, 0))
+  
+  l2.BackColor = LZ.BackColor
+  l4.BackColor = LZ.BackColor
+  l6.BackColor = LZ.BackColor
+  l8.BackColor = LZ.BackColor
+  
+  greyCol = ColorGetLuma(LH.BackColor)
+  lh1.ForeColor = IIf(greyCol < 127, RGB(255, 255, 255), RGB(0, 0, 0))
+  lh2.ForeColor = IIf(greyCol < 127, RGB(255, 255, 255), RGB(0, 0, 0))
+    
+  greyCol = ColorGetLuma(props_.sectionColor)
+  ltp.ForeColor = IIf(greyCol < 127, RGB(255, 255, 255), RGB(0, 0, 0))
+  
+  greyCol = ColorGetLuma(LS.BackColor)
+  ls1.ForeColor = IIf(greyCol < 127, RGB(255, 255, 255), RGB(0, 0, 0))
+  
+  props_.textSpacing = Spin.Value / 10
+  
+  eventsOn_ = True
+End Function
+
+Private Sub bodB_Change()
+  If Not eventsOn_ Then _
+    Exit Sub
+  props_.cGrid = bodB.Value
+  Call UpdateFM
+End Sub
+
+Private Sub headB_Change()
+  If Not eventsOn_ Then _
+    Exit Sub
+  props_.cHeading = headB.Value
+  Call UpdateFM
+End Sub
+
+Private Sub okBTN_Click()
+  isCancelled_ = False
+  Me.Hide
+End Sub
+
+Private Sub Spin_Change()
+  txtSpc.Value = "0." & Spin.Value
+  props_.textSpacing = Spin.Value / 10
+End Sub
+
+Private Sub subB_Change()
+  If Not eventsOn_ Then _
+    Exit Sub
+  props_.cSubHead = subB.Value
+  Call UpdateFM
+End Sub
+
+Private Sub zerB_Change()
+  If Not eventsOn_ Then _
+    Exit Sub
+  props_.cZebra = zerB.Value
+  Call UpdateFM
+End Sub

src/dialogs/CDD_TablePrototype.frm

@@ -0,0 +1,46 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CDD_TablePrototype 
+   Caption         =   "Âûáåðèòå ïðîòîòèï"
+   ClientHeight    =   1620
+   ClientLeft      =   120
+   ClientTop       =   465
+   ClientWidth     =   3525
+   OleObjectBlob   =   "CDD_TablePrototype.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "CDD_TablePrototype"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Option Explicit
+
+Public isCancelled_ As Boolean
+
+Private Sub UserForm_Initialize()
+  isCancelled_ = True
+End Sub
+
+Public Function Init(nId&)
+  isCancelled_ = True
+  TextBox1.Text = Trim(Str(nId))
+End Function
+
+Public Property Get applyToAll() As Boolean
+  applyToAll = CheckBox1.Value
+End Property
+
+Public Property Get GetPickedID() As Long
+  GetPickedID = CLng(TextBox1.Text)
+End Property
+
+Private Sub okBTN_Click()
+  isCancelled_ = False
+  Me.Hide
+End Sub
+
+Private Sub CancelBtn_Click()
+  isCancelled_ = True
+  Me.Hide
+End Sub
+

src/z_UIMessages.bas

@@ -0,0 +1,70 @@
+Attribute VB_Name = "z_UIMessages"
+' Messaging module
+Option Private Module
+Option Explicit
+
+Public Enum MsgCode
+  EM_TABLE_NOT_SELECTED
+  EM_TABLE_MERGED_CELLS
+  EM_TABLE_OUTSIDE_SECTION
+  EM_INVALID_CONTENTS_TABLE
+  EM_CANNOT_INSERT_IMAGE
+  EM_FIX_LINING_FAIL
+  EM_INVALID_TABLE_COLUMNS
+  
+  IM_AUTODESIGN_OK
+  IM_FIX_LINES_OK
+  IM_REPAINT_OK
+  IM_FOOTER_OK
+  IM_FIX_BOOKMARK_NAME
+End Enum
+
+Private g_UI As API_UserInteraction
+
+Public Function UserInteraction() As API_UserInteraction
+  If g_UI Is Nothing Then _
+    Set g_UI = New API_UserInteraction
+  Set UserInteraction = g_UI
+End Function
+
+Public Function SetUserInteraction(newUI As API_UserInteraction)
+  Set g_UI = newUI
+End Function
+
+Public Function UIShowMessage(theCode As MsgCode, ParamArray params() As Variant)
+  Dim unwrapped As Variant: unwrapped = params
+  unwrapped = FixForwardedParams(unwrapped)
+  
+  Select Case theCode
+  Case EM_TABLE_NOT_SELECTED:     Call MsgBox("Âûáåðèòå òàáëèöó!", vbExclamation)
+  Case EM_TABLE_MERGED_CELLS:     Call MsgBox("Òàáëèöà íå äîëæíà ñîäåðæàòü âåðòèêàëüíî îáúåäèí¸ííûõ ÿ÷ååê", vbCritical)
+  Case EM_TABLE_OUTSIDE_SECTION:  Call MsgBox("Íåâîçìîæíî ïîêðàñèòü òàáëèöó âíå ðàçäåëà", vbExclamation)
+  Case EM_INVALID_CONTENTS_TABLE: Call MsgBox("Îãëàâëåíèå êîí÷èëîñü ðàíüøå çàãîëîâêîâ! Îáíîâèòå îãëàâëåíèå!", vbExclamation)
+  Case EM_CANNOT_INSERT_IMAGE:    Call MsgBox("Íåâîçìîæíî âñòàâèòü ôàéë êàðòèíêè!", vbCritical)
+  Case EM_FIX_LINING_FAIL:        Call MsgBox("Îøèáêà ïðè ïîäãîíå èíòåðâàëà, îáðàòèòåñü ê ðàçðàáîò÷èêó!", vbCritical)
+  Case EM_INVALID_TABLE_COLUMNS:  Call MsgBox("Â òàáëèöå ìèíèìóì 2 ñòîëáöà", vbCritical)
+    
+  Case IM_AUTODESIGN_OK:          Call MsgBox("Ìàêåò ñãåíåðèðîâàí", vbInformation)
+  Case IM_FIX_LINES_OK:           Call MsgBox("Áàëàíñèðîâàíèå ñòðîê çàâåðøåíî óñïåøíî", vbInformation)
+  Case IM_REPAINT_OK:             Call MsgBox("Ïîêðàñêà ïðîèçâåäåíà óñïåøíî!", vbInformation)
+  Case IM_FOOTER_OK:              Call MsgBox("Âñå êîëîíòèòóëû óñïåøíî ôîðìàòèðîâàíû!", vbInformation)
+  Case IM_FIX_BOOKMARK_NAME:      Call MsgBox(Fmt("Íåêîððåêòíîå èìÿ, èçìåíåíî íà {1}", unwrapped), vbInformation)
+  
+  Case Else:                      Call MsgBox("Íåâåðíûé êîä ñîîáùåíèÿ", vbCritical)
+  End Select
+End Function
+
+Public Function UIAskQuestion(theCode As MsgCode, ParamArray params() As Variant) As Boolean
+  Dim unwrapped As Variant: unwrapped = params
+  unwrapped = FixForwardedParams(unwrapped)
+  
+  Dim answer&: answer = vbNo
+  Select Case theCode
+'  Case QM_CODE_DELETE_CONFIRM
+'    answer = MsgBox("Are you sure you want to delete ALL macros from target file?", vbYesNo + vbQuestion)
+    
+  Case Else
+    Call MsgBox("Íåâåðíûé êîä ñîîáùåíèÿ", vbCritical)
+  End Select
+  UIAskQuestion = answer = vbYes
+End Function

src/z_UIRibbon.bas

@@ -0,0 +1,31 @@
+Attribute VB_Name = "z_UIRibbon"
+Option Explicit
+
+Sub CCD_OnRibbonBtn(iControl As IRibbonControl)
+  Select Case iControl.ID
+  Case "AutoDesign":        Call CDA_AutoDesign
+  Case "FixLines":          Call CDA_FixLines
+  Case "ColorAll":          Call CDA_Repaint
+  Case "PaintTable":        Call CDA_PaintTable
+  Case "AddPict":           Call CDA_InsertObject
+  
+  Case "FooterHeaderMaster": Call CDA_FooterHeader
+  Case "IntBlock":          Call CDA_CreateBlocking
+  Case "UpdTOC":            Call CDA_UpdateToC
+  
+  Case "InsertHeader":      Call CDA_InsertHeader
+  Case "InsertPageBreak":   Call CDA_InsertBreak
+  
+  Case "InlinePNG":         Call CDA_InlineObjects
+  Case "InlineFields":      Call CDA_InlineFields
+  Case "ScaleFont":         Call CDA_ScaleFont
+  
+  Case "TS_Align":          Call CDA_TSAlign
+  Case "TS_Slice":          Call CDA_TSSlice
+  Case "TS_Paint":          Call CDA_TSPaint
+      
+  Case "AuditDesign":       Call CDA_Audit
+  
+  Case "Help":              Call CDA_Help
+  End Select
+End Sub

ui/.rels

@@ -0,0 +1,2 @@
+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
+<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships"><Relationship Id="rId1" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument" Target="word/document.xml"/><Relationship Id="rId6" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties" Target="docProps/app.xml"/><Relationship Id="rId5" Type="http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties" Target="docProps/core.xml"/><Relationship Id="rId4" Type="http://schemas.microsoft.com/office/2006/relationships/ui/extensibility" Target="customUI/customUI.xml"/></Relationships>

ui/customUI.xml

@@ -0,0 +1,98 @@
+<?xml version="1.0" encoding="utf-8"?>
+<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" xmlns:CC="CONCEPT">
+	<ribbon startFromScratch="false">
+	<tabs>
+	<tab idQ="CC:Concept" label="КОНЦЕПТ">
+	<group id="Design" label="Макетирование" imageMso="PageColorPicker">		
+		<button id="FixLines" size="large"
+			label="Баланс строк"
+			supertip="Скорректировать баланс строк в заголовках и положения объектов на полях"
+			imageMso="PivotTableLayoutReportLayout"
+			onAction="CCD_OnRibbonBtn"/>
+		<button id="ColorAll" size="large"
+			label="Обновить цвета"
+			supertip="Применить цветовую схему к документу"
+			imageMso="AppointmentColorDialog"
+			onAction="CCD_OnRibbonBtn"/>
+		
+		<menu id="DesignElementsMenu" label="Элементы" imageMso="ChartColorsGallery" size="large">
+			<button id="AddPict" label="Вставить на поле"
+				supertip="Добавить пиктограмму, рисунок или текст на поля"
+				imageMso="PictureStylesGallery"
+				onAction="CCD_OnRibbonBtn"/>
+			<button id="InsertHeader" label="Заголовок"
+				supertip="Добавить нумерованный подзаголовок"
+				imageMso="ReviewBalloonsMenu"
+				onAction="CCD_OnRibbonBtn"/>
+			<button id="UpdTOC" label="Оглавление"
+				supertip="Обновить текст и цвета оглавления"
+				imageMso="SlideMasterTextPlaceholderInsert"
+				onAction="CCD_OnRibbonBtn"/>
+			<button id="FooterHeaderMaster"	label="Колонтитулы"
+				supertip="Автоматически проставить колонтитулы"
+				imageMso="PostcardWizard"
+				onAction="CCD_OnRibbonBtn"/>
+		</menu>
+		
+		<menu id="DesignTransformMenu" label="Morph" imageMso="AdpManageIndexes" size="large">
+			<button id="IntBlock" label="Блок"
+				supertip="Подгон отступов выделенного фрагмента для формирования блока в двухколоночном разделе"
+				imageMso="ViewGridlinesFrontPage"
+				onAction="CCD_OnRibbonBtn"/>
+			<button id="InsertPageBreak" label="Разрыв"
+				supertip="Вставить разрыв колонок"
+				imageMso="GroupBlogPublish"
+				onAction="CCD_OnRibbonBtn"/>
+			<button id="InlinePNG" label="PNG"
+				supertip ="Конвертировать изображения абзаца в PNG"
+				imageMso="PictureChange"
+				onAction="CCD_OnRibbonBtn"/>
+			<button id="InlineFields" label="-Коды"
+				supertip="Замена полей на текст"
+				imageMso="CreateLabels"
+				onAction="CCD_OnRibbonBtn"/>
+			<button id="ScaleFont" label="Лупа"
+				supertip="Масштабировать макет"
+				imageMso="ViewFullScreenReadingView"
+				onAction="CCD_OnRibbonBtn"/>
+		</menu>
+		
+		<menu id="DesignTableMenu" label="Таблица" imageMso="AccessListCustomDatasheet" size="large">
+			<button id="PaintTable" label="Красить таблицу"
+				supertip="Перекрасить выделенную таблицу"
+				imageMso="CreateTableUsingSharePointListsGallery"
+				onAction="CCD_OnRibbonBtn"/>
+			<button id="TS_Align" label="Подготовка"
+				supertip="Начать подготовку к нарезанию таблицы на разворот"
+				imageMso="AccessTableEvents"
+				onAction="CCD_OnRibbonBtn"/>
+			<button id="TS_Slice" label="Нарезка"
+				supertip="Нарезать таблицу на разворот страниц"
+				imageMso="CreateQueryInDesignView"
+				onAction="CCD_OnRibbonBtn"/>
+			<button id="TS_Paint" label="Покраска"
+				supertip="Меню настройки цветов таблицы"
+				imageMso="CopyToPersonalCalendar"
+				onAction="CCD_OnRibbonBtn"/>
+		</menu>
+
+		<button id="AuditDesign" size="large"
+			label="Проверить макет"
+			supertip="Обнаружение некоторых распространённых ошибок в макете"
+			imageMso="ChartResetToMatchStyle"
+			onAction="CCD_OnRibbonBtn"/>
+		<button id="AutoDesign" size="large"
+			label="Автомакет"
+			supertip="Создать макет текущего отчета"
+			imageMso="ChangeStylesMenu"
+			onAction="CCD_OnRibbonBtn"/>
+		<button id="Help" size="large"
+			label="Справка"
+			supertip="Вызов справки по надстройкам Word"
+			imageMso="Info"
+			onAction="CCD_OnRibbonBtn"/>
+	</group>
+	</tab>
+	</tabs>
+	</ribbon>
+</customUI>