commit 2c8b91e305d21e888e66550601938c7b151af33e
Author: IRBorisov <8611739+IRBorisov@users.noreply.github.com>
Date: Fri Jun 7 20:07:08 2024 +0300
Initial commit
diff --git a/VBAMake.txt b/VBAMake.txt
new file mode 100644
index 0000000..88f525a
--- /dev/null
+++ b/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
\ No newline at end of file
diff --git a/VERSION b/VERSION
new file mode 100644
index 0000000..9084fa2
--- /dev/null
+++ b/VERSION
@@ -0,0 +1 @@
+1.1.0
diff --git a/distr/!Руководство пользователя.docx b/distr/!Руководство пользователя.docx
new file mode 100644
index 0000000..4dca1f0
Binary files /dev/null and b/distr/!Руководство пользователя.docx differ
diff --git a/script/manifest.txt b/script/manifest.txt
new file mode 100644
index 0000000..0de96ac
--- /dev/null
+++ b/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
\ No newline at end of file
diff --git a/skeleton/_Maket.dotm b/skeleton/_Maket.dotm
new file mode 100644
index 0000000..36d9991
Binary files /dev/null and b/skeleton/_Maket.dotm differ
diff --git a/src/CD_Audit.bas b/src/CD_Audit.bas
new file mode 100644
index 0000000..b0c197c
--- /dev/null
+++ b/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
diff --git a/src/CD_AutoDesign.bas b/src/CD_AutoDesign.bas
new file mode 100644
index 0000000..dbef59c
--- /dev/null
+++ b/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
diff --git a/src/CD_Colontitles.bas b/src/CD_Colontitles.bas
new file mode 100644
index 0000000..ffe1f72
--- /dev/null
+++ b/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
diff --git a/src/CD_Layout.bas b/src/CD_Layout.bas
new file mode 100644
index 0000000..048ae81
--- /dev/null
+++ b/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
+
diff --git a/src/CD_Paint.bas b/src/CD_Paint.bas
new file mode 100644
index 0000000..8681544
--- /dev/null
+++ b/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
diff --git a/src/CD_RedesignFonts.bas b/src/CD_RedesignFonts.bas
new file mode 100644
index 0000000..1ba8a3d
--- /dev/null
+++ b/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
diff --git a/src/CD_SplitTable.bas b/src/CD_SplitTable.bas
new file mode 100644
index 0000000..467cab6
--- /dev/null
+++ b/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
diff --git a/src/CD_WordModule.bas b/src/CD_WordModule.bas
new file mode 100644
index 0000000..5950dda
--- /dev/null
+++ b/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
diff --git a/src/Declarations.bas b/src/Declarations.bas
new file mode 100644
index 0000000..0d5617b
--- /dev/null
+++ b/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
+
diff --git a/src/DevHelper.bas b/src/DevHelper.bas
new file mode 100644
index 0000000..40b83c6
--- /dev/null
+++ b/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
diff --git a/src/IconPicker.cls b/src/IconPicker.cls
new file mode 100644
index 0000000..c0459cd
--- /dev/null
+++ b/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
diff --git a/src/InfoDocument.cls b/src/InfoDocument.cls
new file mode 100644
index 0000000..637a734
--- /dev/null
+++ b/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
diff --git a/src/ItemChapter.cls b/src/ItemChapter.cls
new file mode 100644
index 0000000..ded34e7
--- /dev/null
+++ b/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
diff --git a/src/ItemColontitles.cls b/src/ItemColontitles.cls
new file mode 100644
index 0000000..166f5db
--- /dev/null
+++ b/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
diff --git a/src/ItemFontScale.cls b/src/ItemFontScale.cls
new file mode 100644
index 0000000..87eddc1
--- /dev/null
+++ b/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
diff --git a/src/Main.bas b/src/Main.bas
new file mode 100644
index 0000000..492a43d
--- /dev/null
+++ b/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
diff --git a/src/MainImpl.bas b/src/MainImpl.bas
new file mode 100644
index 0000000..b769195
--- /dev/null
+++ b/src/MainImpl.bas
@@ -0,0 +1,6 @@
+Attribute VB_Name = "MainImpl"
+Option Explicit
+
+
+' =============
+
diff --git a/src/dialogs/CDD_AddPict.frm b/src/dialogs/CDD_AddPict.frm
new file mode 100644
index 0000000..2571820
--- /dev/null
+++ b/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
diff --git a/src/dialogs/CDD_AddPict.frx b/src/dialogs/CDD_AddPict.frx
new file mode 100644
index 0000000..5133e06
Binary files /dev/null and b/src/dialogs/CDD_AddPict.frx differ
diff --git a/src/dialogs/CDD_AutoDesign.frm b/src/dialogs/CDD_AutoDesign.frm
new file mode 100644
index 0000000..8e6e5f4
--- /dev/null
+++ b/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
diff --git a/src/dialogs/CDD_AutoDesign.frx b/src/dialogs/CDD_AutoDesign.frx
new file mode 100644
index 0000000..36c7f15
Binary files /dev/null and b/src/dialogs/CDD_AutoDesign.frx differ
diff --git a/src/dialogs/CDD_FontScaling.frm b/src/dialogs/CDD_FontScaling.frm
new file mode 100644
index 0000000..620f068
--- /dev/null
+++ b/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
diff --git a/src/dialogs/CDD_FontScaling.frx b/src/dialogs/CDD_FontScaling.frx
new file mode 100644
index 0000000..3721a82
Binary files /dev/null and b/src/dialogs/CDD_FontScaling.frx differ
diff --git a/src/dialogs/CDD_HeaderFooter.frm b/src/dialogs/CDD_HeaderFooter.frm
new file mode 100644
index 0000000..dc9d3e8
--- /dev/null
+++ b/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
diff --git a/src/dialogs/CDD_HeaderFooter.frx b/src/dialogs/CDD_HeaderFooter.frx
new file mode 100644
index 0000000..5a38073
Binary files /dev/null and b/src/dialogs/CDD_HeaderFooter.frx differ
diff --git a/src/dialogs/CDD_Paint.frm b/src/dialogs/CDD_Paint.frm
new file mode 100644
index 0000000..32ca545
--- /dev/null
+++ b/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
diff --git a/src/dialogs/CDD_Paint.frx b/src/dialogs/CDD_Paint.frx
new file mode 100644
index 0000000..165d122
Binary files /dev/null and b/src/dialogs/CDD_Paint.frx differ
diff --git a/src/dialogs/CDD_RunAudit.frm b/src/dialogs/CDD_RunAudit.frm
new file mode 100644
index 0000000..6df971f
--- /dev/null
+++ b/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
diff --git a/src/dialogs/CDD_RunAudit.frx b/src/dialogs/CDD_RunAudit.frx
new file mode 100644
index 0000000..37d0bb5
Binary files /dev/null and b/src/dialogs/CDD_RunAudit.frx differ
diff --git a/src/dialogs/CDD_TableColors.frm b/src/dialogs/CDD_TableColors.frm
new file mode 100644
index 0000000..ae3c02b
--- /dev/null
+++ b/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
diff --git a/src/dialogs/CDD_TableColors.frx b/src/dialogs/CDD_TableColors.frx
new file mode 100644
index 0000000..4407051
Binary files /dev/null and b/src/dialogs/CDD_TableColors.frx differ
diff --git a/src/dialogs/CDD_TablePrototype.frm b/src/dialogs/CDD_TablePrototype.frm
new file mode 100644
index 0000000..0c6b291
--- /dev/null
+++ b/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
+
diff --git a/src/dialogs/CDD_TablePrototype.frx b/src/dialogs/CDD_TablePrototype.frx
new file mode 100644
index 0000000..3e3d5dd
Binary files /dev/null and b/src/dialogs/CDD_TablePrototype.frx differ
diff --git a/src/z_UIMessages.bas b/src/z_UIMessages.bas
new file mode 100644
index 0000000..761ffd5
--- /dev/null
+++ b/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
diff --git a/src/z_UIRibbon.bas b/src/z_UIRibbon.bas
new file mode 100644
index 0000000..f6c06a0
--- /dev/null
+++ b/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
diff --git a/ui/.rels b/ui/.rels
new file mode 100644
index 0000000..2b00f63
--- /dev/null
+++ b/ui/.rels
@@ -0,0 +1,2 @@
+
+
\ No newline at end of file
diff --git a/ui/customUI.xml b/ui/customUI.xml
new file mode 100644
index 0000000..475ea64
--- /dev/null
+++ b/ui/customUI.xml
@@ -0,0 +1,98 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
\ No newline at end of file