commit da1c04d8fcb603ad064b6fc19bb86ea923b2de1c Author: IRBorisov <8611739+IRBorisov@users.noreply.github.com> Date: Fri Jun 7 20:08:00 2024 +0300 Initial commit diff --git a/VBAMake.txt b/VBAMake.txt new file mode 100644 index 0000000..33becc8 --- /dev/null +++ b/VBAMake.txt @@ -0,0 +1,52 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact_home, source_home + +id = Concept-Markup +name = Концепт-Разметка +description = Модуль разметки текстов в Word +artifact_home = Концепт-Разметка +source_home = Concept-Markup +install_home = \\fs1.concept.ru\projects\10 Автоматизация деятельности\01 Высокие технологии\Концепт-Разметка + +%% +# === Build section === +# Available commands: +# build LOCAL_MANIFEST +# copy LOCAL_SOURCE -> [LOCAL_ARTIFACT] +# save_as LOCAL_ARTIFACT -> LOCAL_ARTIFACT +# run LOCAL_SOURCE.bat + +copy test + +build script\markupManifest.txt +build script\aggregatorManifest.txt +build script\interviewManifest.txt + +copy distr\Надстройка\Install.bat -> Надстройка\Install.bat +copy distr\Надстройка\Uninstall.bat -> Надстройка\Uninstall.bat +copy distr\!!Листовка.docx +copy distr\!Руководство пользователя.docx +copy distr\Разметка + +%% +# === Install section == +# Available commands: +# install LOCAL_ARTIFACT -> [INSTALL_PATH] +# add_template LOCAL_ARTIFACT -> [LOCAL_TEMPLATE] +# run LOCAL_ARTIFACT.bat <- [PARAMETERS] +# run APPLICATION <- [PARAMETERS] + +install Утилиты\!Агрегатор расчисток.xlsm +install Утилиты\!Сборка расчисток интервью.xlsm +install Надстройка\Install.bat -> Надстройка\Install.bat +install Надстройка\Uninstall.bat -> Надстройка\Uninstall.bat +install Надстройка\MARKUP.dotm -> Надстройка\MARKUP.dotm +install Разметка + +install !!Листовка.docx +install !Руководство пользователя.docx + +install Надстройка\MARKUP.dotm -> \\fs1.concept.ru\Exchange\ConceptDistr\data\Add-ins\Word\MARKUP.dotm +add_template Разметка \ 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..41e233d Binary files /dev/null and b/distr/!!Листовка.docx differ diff --git a/distr/!Руководство пользователя.docx b/distr/!Руководство пользователя.docx new file mode 100644 index 0000000..c124477 Binary files /dev/null and b/distr/!Руководство пользователя.docx differ diff --git a/distr/Надстройка/Install.bat b/distr/Надстройка/Install.bat new file mode 100644 index 0000000..149cf28 --- /dev/null +++ b/distr/Надстройка/Install.bat @@ -0,0 +1,3 @@ +@echo off + +copy "MARKUP.dotm" "%APPDATA%\Microsoft\Word\STARTUP\" \ No newline at end of file diff --git a/distr/Надстройка/Uninstall.bat b/distr/Надстройка/Uninstall.bat new file mode 100644 index 0000000..fbe554d --- /dev/null +++ b/distr/Надстройка/Uninstall.bat @@ -0,0 +1,3 @@ +@echo off + +del "%APPDATA%\Microsoft\Word\STARTUP\MARKUP.dotm" \ No newline at end of file diff --git a/distr/Разметка/!Шаблон конфигурации.dotx b/distr/Разметка/!Шаблон конфигурации.dotx new file mode 100644 index 0000000..4dd2138 Binary files /dev/null and b/distr/Разметка/!Шаблон конфигурации.dotx differ diff --git a/distr/Разметка/01 Маркеры.docx b/distr/Разметка/01 Маркеры.docx new file mode 100644 index 0000000..875c38a Binary files /dev/null and b/distr/Разметка/01 Маркеры.docx differ diff --git a/distr/Разметка/11 Расчистка НПА.docx b/distr/Разметка/11 Расчистка НПА.docx new file mode 100644 index 0000000..a6d972b Binary files /dev/null and b/distr/Разметка/11 Расчистка НПА.docx differ diff --git a/distr/Разметка/12 Карта субъектов.docx b/distr/Разметка/12 Карта субъектов.docx new file mode 100644 index 0000000..454e84b Binary files /dev/null and b/distr/Разметка/12 Карта субъектов.docx differ diff --git a/distr/Разметка/13 Расчистка интервью.docx b/distr/Разметка/13 Расчистка интервью.docx new file mode 100644 index 0000000..0f4058e Binary files /dev/null and b/distr/Разметка/13 Расчистка интервью.docx differ diff --git a/distr/Разметка/14 Расчистка НПА 2.0.docx b/distr/Разметка/14 Расчистка НПА 2.0.docx new file mode 100644 index 0000000..1636ee0 Binary files /dev/null and b/distr/Разметка/14 Расчистка НПА 2.0.docx differ diff --git a/distr/Разметка/20 Авторская концепция.docx b/distr/Разметка/20 Авторская концепция.docx new file mode 100644 index 0000000..af77f55 Binary files /dev/null and b/distr/Разметка/20 Авторская концепция.docx differ diff --git a/distr/Разметка/21 Именованные сущности.docx b/distr/Разметка/21 Именованные сущности.docx new file mode 100644 index 0000000..a2d4255 Binary files /dev/null and b/distr/Разметка/21 Именованные сущности.docx differ diff --git a/distr/Разметка/30 Концептуальные конструкции.docx b/distr/Разметка/30 Концептуальные конструкции.docx new file mode 100644 index 0000000..e3361fa Binary files /dev/null and b/distr/Разметка/30 Концептуальные конструкции.docx differ diff --git a/script/aggregatorManifest.txt b/script/aggregatorManifest.txt new file mode 100644 index 0000000..5173a95 --- /dev/null +++ b/script/aggregatorManifest.txt @@ -0,0 +1,100 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact + +name = !Агрегатор расчисток.xlsm +artifact = Утилиты\!Агрегатор расчисток.xlsm + +%% +# === Imports Section === +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SharedHome path + +api + ex_WinAPI.bas + ex_Metadata.bas + API_Path.cls + API_WordWrapper.cls + API_XLWrapper.cls + API_UserInteraction.cls + +utility + ex_VBA.bas + ex_Collection.bas + ex_DataPreparation.bas + CDS_Interval.cls + CDS_CompoundIntervals.cls + +excel + ex_Excel.bas + +word + ex_Word.bas + +ui + CSE_ProgressBar.frm + +dev + DevTester.bas + +%% +# === Source Code Section == +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SourceHome path + +src + common + MU_Declarations.bas + + MarkupAPI.cls + InfoCategory.cls + InfoConfig.cls + InfoFormat.cls + InfoDocument.cls + + ItemConfigDescriptor.cls + ItemFragment.cls + + IteratorFormat.cls + IteratorStyle.cls + + aggregator + MUD_ImportWord.frm + + DevHelper.bas + Declarations.bas + Main.bas + MainImpl.bas + z_UIRibbon.bas + z_UIMessages.bas + + DB_Markup.cls + ItemSource.cls + ItemLink.cls + + test + s_DBMarkup.cls + +%% +# ===== 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 + +aggregator\.rels -> _rels\.rels +aggregator\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 : Word +global : MSForms \ No newline at end of file diff --git a/script/interviewManifest.txt b/script/interviewManifest.txt new file mode 100644 index 0000000..c5604aa --- /dev/null +++ b/script/interviewManifest.txt @@ -0,0 +1,55 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact + +name = !Сборка расчисток интервью.xlsm +artifact = Утилиты\!Сборка расчисток интервью.xlsm + +%% +# === Imports Section === +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SharedHome path + +api + ex_WinAPI.bas + API_XLWrapper.cls + API_UserInteraction.cls + +utility + ex_VBA.bas + ex_Collection.bas + +%% +# === Source Code Section == +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SourceHome path + +src + utils + interview + Declarations.bas + Main.bas + MainImpl.bas + z_UIMessages.bas + +%% +# ===== 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 + + + +%% +# === References Section === +# List dependencies in one of the formats +# global : GLOBAL_NAME +# guid : {REGISTERED_GUID} +# file : PATH_TO_LIBRARY + +global : Shell32 +global : Scripting +global : MSForms \ No newline at end of file diff --git a/script/markupManifest.txt b/script/markupManifest.txt new file mode 100644 index 0000000..a775642 --- /dev/null +++ b/script/markupManifest.txt @@ -0,0 +1,98 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact + +name = MARKUP.dotm +artifact = Надстройка\MARKUP.dotm + +%% +# === Imports Section === +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SharedHome path + +api + ex_WinAPI.bas + ex_Metadata.bas + + API_Path.cls + API_WordWrapper.cls + API_XLWrapper.cls + API_Ribbon.cls + API_UserInteraction.cls + +utility + ex_VBA.bas + ex_DataPreparation.bas + ex_Collection.bas + CDS_Interval.cls + CDS_CompoundIntervals.cls + +word + ex_Word.bas + +dev + DevTester.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 + common + MU_Declarations.bas + + MarkupAPI.cls + InfoCategory.cls + InfoConfig.cls + InfoFormat.cls + InfoDocument.cls + + ItemConfigDescriptor.cls + ItemFragment.cls + + IteratorFormat.cls + IteratorStyle.cls + + markup + DevHelper.bas + Declarations.bas + Main.bas + MainImpl.bas + z_UIRibbon.bas + z_UIMessages.bas + + test + s_Category.cls + s_Config.cls + s_Format.cls + s_MarkupAPI.cls + s_WordDocument.cls + +%% +# ===== 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 + +markup\.rels -> _rels\.rels +markup\customUI.xml -> customUI\customUI.xml +markup\customizations.xml -> word\customizations.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/!Агрегатор расчисток.xlsm b/skeleton/!Агрегатор расчисток.xlsm new file mode 100644 index 0000000..9e535a5 Binary files /dev/null and b/skeleton/!Агрегатор расчисток.xlsm differ diff --git a/skeleton/!Сборка расчисток интервью.xlsm b/skeleton/!Сборка расчисток интервью.xlsm new file mode 100644 index 0000000..7d2954b Binary files /dev/null and b/skeleton/!Сборка расчисток интервью.xlsm differ diff --git a/skeleton/MARKUP.dotm b/skeleton/MARKUP.dotm new file mode 100644 index 0000000..a0ae666 Binary files /dev/null and b/skeleton/MARKUP.dotm differ diff --git a/src/aggregator/DB_Markup.cls b/src/aggregator/DB_Markup.cls new file mode 100644 index 0000000..d4607ec --- /dev/null +++ b/src/aggregator/DB_Markup.cls @@ -0,0 +1,166 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "DB_Markup" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private data_ As Excel.Worksheet +Private sources_ As Excel.Worksheet + +Public Function Init(iData As Excel.Worksheet, iSources As Excel.Worksheet) + Set data_ = iData + Set sources_ = iSources +End Function + +Public Function RemoveAll() + Call data_.UsedRange.Offset(1, 0).ClearContents + Call sources_.UsedRange.Offset(1, 0).ClearContents +End Function + +Public Function GetLinkFor(nDataRow&) As ItemLink + If data_.Cells(nDataRow, S_DATA_ID) = vbNullString Then _ + Exit Function + Dim sPath$: sPath = FindSourcePath(data_.Cells(nDataRow, S_DATA_SOURCE)) + If sPath = vbNullString Then _ + Exit Function + + Dim iLink As New ItemLink + iLink.start_ = data_.Cells(nDataRow, S_DATA_START) + iLink.finish_ = data_.Cells(nDataRow, S_DATA_FINISH) + iLink.path_ = sPath + + Set GetLinkFor = iLink +End Function + +Public Function ImportFromExcel(iSource As Excel.Worksheet) As Boolean + ImportFromExcel = False + + Dim iPath As New API_Path: Call iPath.FromString(iSource.Cells(FIRST_ROW, S_IN_SOURCE)) + Dim intSource As ItemSource: Set intSource = PrepareSourceInput(iPath) + If intSource Is Nothing Then _ + Exit Function + + Dim rowOut&: rowOut = intSource.rowOut_ + Dim rowIn&: rowIn = FIRST_ROW + Do While iSource.Cells(rowIn, S_IN_START) <> vbNullString + data_.Cells(rowOut, S_DATA_ID) = intSource.sourceID_ & "-" & VBA.Format(rowIn - 1, "0000") + data_.Cells(rowOut, S_DATA_SOURCE) = intSource.sourceID_ + data_.Cells(rowOut, S_DATA_START) = iSource.Cells(rowIn, S_IN_START) + data_.Cells(rowOut, S_DATA_FINISH) = iSource.Cells(rowIn, S_IN_FINISH) + data_.Cells(rowOut, S_DATA_TYPE) = iSource.Cells(rowIn, S_IN_TYPE) + data_.Cells(rowOut, S_DATA_TEXT) = iSource.Cells(rowIn, S_IN_TEXT) + data_.Cells(rowOut, S_DATA_COMMENT) = iSource.Cells(rowIn, S_IN_COMMENT) + rowOut = rowOut + 1 + rowIn = rowIn + 1 + Loop + + ImportFromExcel = True +End Function + +Public Function ImportFromWord(iSource As InfoDocument) As Boolean + ImportFromWord = False + + Dim frags As Collection: Set frags = iSource.GetBasicFragmentsCompound() + Dim iPath As New API_Path: Call iPath.FromString(iSource.doc_.FullName).GlobalToServer + Dim intSource As ItemSource: Set intSource = PrepareSourceInput(iPath) + If intSource Is Nothing Then _ + Exit Function + + Dim rowOut&: rowOut = intSource.rowOut_ + Dim rowStart&: rowStart = intSource.rowOut_ + Dim nItem&: nItem = 1 + Dim aFrag As ItemFragment + For Each aFrag In frags + Dim theRange As Word.Range: Set theRange = iSource.doc_.Range(aFrag.start_, aFrag.end_) + + data_.Cells(rowOut, S_DATA_ID) = intSource.sourceID_ & "-" & VBA.Format(nItem - 1, "0000") + data_.Cells(rowOut, S_DATA_SOURCE) = intSource.sourceID_ + data_.Cells(rowOut, S_DATA_START) = aFrag.start_ + data_.Cells(rowOut, S_DATA_FINISH) = aFrag.end_ + data_.Cells(rowOut, S_DATA_TYPE) = aFrag.id_ + data_.Cells(rowOut, S_DATA_TEXT) = theRange.Text + data_.Cells(rowOut, S_DATA_COMMENT) = ExtractCommentText(theRange) + + nItem = nItem + 1 + rowOut = rowOut + 1 + Next aFrag + + Call data_.Range(data_.Cells(rowStart, S_DATA_ID), data_.Cells(rowOut - 1, S_DATA_COMMENT)).Sort( _ + Key1:=data_.Cells(rowStart, S_DATA_START), _ + Order1:=xlAscending, _ + Key2:=data_.Cells(rowStart, S_DATA_FINISH), _ + Order2:=xlDescending, _ + Header:=xlNo) + + ImportFromWord = True +End Function + +' ====== +Private Function PrepareSourceInput(iPath As API_Path) As ItemSource + Dim iSource As New ItemSource + Dim nRow&: nRow = FIRST_ROW + Dim sPath$: sPath = iPath.Text + Do While sources_.Cells(nRow, S_SRC_ID) <> vbNullString + If sources_.Cells(nRow, S_SRC_PATH) = sPath Then + If Not UserInteraction.AskQuestion(QM_CLEAR_BEFORE_READD) Then _ + Exit Function + Call RemoveSource(nRow) + Else + nRow = nRow + 1 + End If + Loop + + iSource.rowSource_ = nRow + iSource.sourceID_ = Excel.Application.WorksheetFunction.Max(sources_.Range("A:A")) + 1 + iSource.rowOut_ = GetLastDataRow + + Call OutputSource(iSource, iPath) + + Set PrepareSourceInput = iSource +End Function + +Private Function OutputSource(iSource As ItemSource, iPath As API_Path) + sources_.Cells(iSource.rowSource_, S_SRC_ID) = iSource.sourceID_ + sources_.Cells(iSource.rowSource_, S_SRC_NAME) = iPath.BaseName + Dim iCell As Excel.Range: Set iCell = sources_.Cells(iSource.rowSource_, S_SRC_PATH) + iCell = iPath.Text + Call XLUpdateHyperlink(iCell, iPath.Text) +End Function + +Private Function RemoveSource(nRow&) + Dim nSource&: nSource = sources_.Cells(nRow, S_SRC_ID) + Call sources_.Rows(nRow).Delete + + Dim nDataRow&: nDataRow = FIRST_ROW + Do While data_.Cells(nDataRow, S_DATA_ID) <> vbNullString + If data_.Cells(nDataRow, S_DATA_SOURCE) = nSource Then + data_.Rows(nDataRow).Delete + Else + nDataRow = nDataRow + 1 + End If + Loop +End Function + +Private Function GetLastDataRow() As Long + Dim nRow&: nRow = FIRST_ROW + Do While data_.Cells(nRow, S_DATA_ID) <> vbNullString + nRow = nRow + 1 + Loop + GetLastDataRow = nRow +End Function + +Private Function FindSourcePath(nSource&) As String + Dim nRow&: nRow = FIRST_ROW + Do While sources_.Cells(nRow, S_SRC_ID) <> vbNullString + If sources_.Cells(nRow, S_SRC_ID) = nSource Then + FindSourcePath = sources_.Cells(nRow, S_SRC_PATH) + Exit Function + End If + nRow = nRow + 1 + Loop +End Function diff --git a/src/aggregator/Declarations.bas b/src/aggregator/Declarations.bas new file mode 100644 index 0000000..049b954 --- /dev/null +++ b/src/aggregator/Declarations.bas @@ -0,0 +1,35 @@ +Attribute VB_Name = "Declarations" +Option Explicit +Option Private Module + +Public Const SHEET_DATA = "" +Public Const SHEET_SOURCES = "" + +Public Const FIRST_ROW = 2 + +Public Enum ItemStructure + S_DATA_ID = 1 + S_DATA_SOURCE = 2 + S_DATA_START = 3 + S_DATA_FINISH = 4 + S_DATA_TYPE = 5 + S_DATA_TEXT = 6 + S_DATA_COMMENT = 7 +End Enum + +Public Enum SourceStructure + S_SRC_ID = 1 + S_SRC_NAME = 2 + S_SRC_PATH = 3 +End Enum + +Public Enum InputStruct + S_IN_ID = 1 + S_IN_START = 2 + S_IN_FINISH = 3 + S_IN_TYPE = 4 + S_IN_TEXT = 5 + S_IN_COMMENT = 6 + S_IN_SOURCE_LABEL = 7 + S_IN_SOURCE = 8 +End Enum diff --git a/src/aggregator/DevHelper.bas b/src/aggregator/DevHelper.bas new file mode 100644 index 0000000..b03a12d --- /dev/null +++ b/src/aggregator/DevHelper.bas @@ -0,0 +1,28 @@ +Attribute VB_Name = "DevHelper" +Option Private Module +Option Explicit + +Private Const TEST_SOURCES = "test" +Private Const TEST_CONFIG = "TestConfig.docx" + +Private Const TEST_FILES = "testFiles" + +Public Function Dev_PrepareSkeleton() + ' Do nothing + Call AccessData.RemoveAll +End Function + +Public Function Dev_ManualRunTest() + Dim sSuite$: sSuite = "s_WordDocument" + Dim sTest$: sTest = "t_IteratorStyle" + 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_DBMarkup": Set Dev_GetTestSuite = New s_DBMarkup + ' Case "s_WordDocument": Set Dev_GetTestSuite = New s_WordDocument + End Select +End Function diff --git a/src/aggregator/ItemLink.cls b/src/aggregator/ItemLink.cls new file mode 100644 index 0000000..ca43715 --- /dev/null +++ b/src/aggregator/ItemLink.cls @@ -0,0 +1,14 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ItemLink" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public path_ As String +Public start_ As Long +Public finish_ As Long diff --git a/src/aggregator/ItemSource.cls b/src/aggregator/ItemSource.cls new file mode 100644 index 0000000..fed0501 --- /dev/null +++ b/src/aggregator/ItemSource.cls @@ -0,0 +1,14 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ItemSource" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public sourceID_ As Long +Public rowOut_ As Long +Public rowSource_ As Long diff --git a/src/aggregator/MUD_ImportWord.frm b/src/aggregator/MUD_ImportWord.frm new file mode 100644 index 0000000..31d8fe5 --- /dev/null +++ b/src/aggregator/MUD_ImportWord.frm @@ -0,0 +1,82 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} MUD_ImportWord + Caption = " Word" + ClientHeight = 1155 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 6780 + OleObjectBlob = "MUD_ImportWord.frx":0000 + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "MUD_ImportWord" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Explicit + +Private configs_ As Collection +Public isCancelled_ As Boolean + +Private Sub UserForm_Initialize() + isCancelled_ = True + Set configs_ = New Collection +End Sub + +Private Sub UserForm_Terminate() + isCancelled_ = True + Call Me.Hide +End Sub + +Public Function Init() + Dim activeConfig As ItemConfigDescriptor: Set activeConfig = SelectedConfig + Dim selectedID&: selectedID = 0 + Set configs_ = GetConfigList + + Call CBConfig.Clear + Dim nItem& + For nItem = 1 To configs_.Count + Dim confName$: confName = configs_.Item(nItem).name_ + Call CBConfig.AddItem(confName) + If Not activeConfig Is Nothing Then _ + If activeConfig.name_ = confName Then _ + selectedID = nItem - 1 + Next nItem + + CBConfig.ListIndex = selectedID + + isCancelled_ = True +End Function + +Public Property Get FileName() As String + FileName = TBDocument.Text +End Property + +Public Property Get SelectedConfig() As ItemConfigDescriptor + If CBConfig.ListIndex <> -1 Then _ + Set SelectedConfig = configs_.Item(CBConfig.ListIndex + 1) +End Property + +Private Sub DocumentBtn_Click() + Dim sFileName$: sFileName = UserInteraction.PromptFileFilter( _ + sInitialPath:=ThisWorkbook.Path, _ + sDescription:=" Word", _ + sFilter:="*.docx;*.doc;*.docm") + If sFileName <> vbNullString Then _ + TBDocument.Text = sFileName +End Sub + +Private Sub CancelBtn_Click() + isCancelled_ = True + Call Me.Hide +End Sub + +Private Sub OkBtn_Click() + If FileName = vbNullString Or SelectedConfig Is Nothing Then + Call UserInteraction.ShowMessage(EM_VALIDATION_FAIL) + Exit Sub + End If + + isCancelled_ = False + Call Me.Hide +End Sub diff --git a/src/aggregator/MUD_ImportWord.frx b/src/aggregator/MUD_ImportWord.frx new file mode 100644 index 0000000..37d977e Binary files /dev/null and b/src/aggregator/MUD_ImportWord.frx differ diff --git a/src/aggregator/Main.bas b/src/aggregator/Main.bas new file mode 100644 index 0000000..b9aec02 --- /dev/null +++ b/src/aggregator/Main.bas @@ -0,0 +1,66 @@ +Attribute VB_Name = "Main" +Option Explicit + +Public Sub RunImportExcel() + Dim sFileName$: sFileName = UserInteraction.PromptFileFilter( _ + sInitialPath:=ThisWorkbook.Path, _ + sDescription:=" Excel", _ + sFilter:="*.xlsx;*.xls;*.xlsm") + If sFileName = vbNullString Then _ + Exit Sub + Dim xlApp As New API_XLWrapper + If xlApp.OpenDocument(sFileName, bReadOnly:=True) Is Nothing Then _ + Exit Sub + + Dim iData As DB_Markup: Set iData = AccessData + Dim bIsLoaded As Boolean: bIsLoaded = iData.ImportFromExcel(xlApp.Document.Sheets(1)) + Call xlApp.ReleaseDocument + + If bIsLoaded Then _ + Call UserInteraction.ShowMessage(IM_IMPORT_OK) +End Sub + +Public Sub RunImportWord() + Call MUD_ImportWord.Init + Call MUD_ImportWord.Show + If MUD_ImportWord.isCancelled_ Then _ + Exit Sub + + Dim theMarkup As New MarkupAPI + If Not theMarkup.config_.Load(MUD_ImportWord.SelectedConfig.path_) Then + Call UserInteraction.ShowMessage(EM_CANNOT_LOAD_CONFIG) + Exit Sub + End If + + Dim wordApp As New API_WordWrapper + If wordApp.OpenDocument(MUD_ImportWord.FileName, bReadOnly:=True) Is Nothing Then _ + Exit Sub + + Dim iData As DB_Markup: Set iData = AccessData + Dim iDoc As New InfoDocument: Call iDoc.Init(wordApp.Document, theMarkup) + Call iDoc.SyncStyles + Dim bIsLoaded As Boolean: bIsLoaded = iData.ImportFromWord(iDoc) + Call wordApp.ReleaseDocument(bSaveChanges:=False) + + If bIsLoaded Then _ + Call UserInteraction.ShowMessage(IM_IMPORT_OK) +End Sub + +Public Sub RunFollowLink() + If Excel.Application.ActiveSheet.Name <> SHEET_DATA Then _ + Exit Sub + + Dim iData As DB_Markup: Set iData = AccessData + Dim nSelectedRow&: nSelectedRow = Excel.Selection.Cells(1, 1).Row + Dim iLink As ItemLink: Set iLink = iData.GetLinkFor(nSelectedRow) + If iLink Is Nothing Then + Call UserInteraction.ShowMessage(EM_INVALID_SOURCE) + Exit Sub + End If + + Call ShowDocumentLink(iLink) +End Sub + +Public Sub RunClearAll() + Call AccessData.RemoveAll +End Sub diff --git a/src/aggregator/MainImpl.bas b/src/aggregator/MainImpl.bas new file mode 100644 index 0000000..bcb0275 --- /dev/null +++ b/src/aggregator/MainImpl.bas @@ -0,0 +1,40 @@ +Attribute VB_Name = "MainImpl" +Option Private Module +Option Explicit + +Public Function AccessData() As DB_Markup + Static s_Data As DB_Markup + + If s_Data Is Nothing Then + Set s_Data = New DB_Markup + Call s_Data.Init(ThisWorkbook.Worksheets(SHEET_DATA), ThisWorkbook.Worksheets(SHEET_SOURCES)) + End If + + Set AccessData = s_Data +End Function + +Public Function ShowDocumentLink(iLink As ItemLink) + Dim fso As New Scripting.FileSystemObject + If Not fso.FileExists(iLink.path_) Then + Call UserInteraction.ShowMessage(EM_FILE_MISSINNG, iLink.path_) + Exit Function + End If + + Dim wordAppl As New API_WordWrapper + If wordAppl.OpenDocument(iLink.path_, bReadOnly:=True) Is Nothing Then _ + Exit Function + + Dim theDoc As Word.Document: Set theDoc = wordAppl.Document + If theDoc.Range.End < iLink.finish_ Then + Call UserInteraction.ShowMessage(EM_FILE_TOO_SHORT) + Exit Function + End If + + Dim targetRng As Word.Range: Set targetRng = theDoc.Range(iLink.start_, iLink.finish_) + Call targetRng.Select + Call theDoc.ActiveWindow.ScrollIntoView(targetRng) + + Call ActivateWindowHwnd(theDoc.ActiveWindow.hwnd) +End Function + + diff --git a/src/aggregator/z_UIMessages.bas b/src/aggregator/z_UIMessages.bas new file mode 100644 index 0000000..c10b81d --- /dev/null +++ b/src/aggregator/z_UIMessages.bas @@ -0,0 +1,62 @@ +Attribute VB_Name = "z_UIMessages" +' Messaging module +Option Private Module +Option Explicit + +Public Enum MsgCode + MSG_OK = 0 + + EM_VALIDATION_FAIL + EM_CANNOT_LOAD_CONFIG + EM_FILE_MISSINNG + EM_FILE_TOO_SHORT + EM_INVALID_SOURCE + + IM_IMPORT_OK + + QM_CLEAR_BEFORE_READD +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_VALIDATION_FAIL: Call MsgBox(" ", vbExclamation) + Case EM_CANNOT_LOAD_CONFIG: Call MsgBox(" ", vbExclamation) + Case EM_FILE_MISSINNG: Call MsgBox(Fmt(" : {1}", unwrapped), vbExclamation) + Case EM_FILE_TOO_SHORT: Call MsgBox(" , ", vbExclamation) + Case EM_INVALID_SOURCE: Call MsgBox(" : ", vbExclamation) + + Case IM_IMPORT_OK: Call MsgBox(" ", vbInformation) + + Case Else: Call MsgBox("Invalid message code", 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_CLEAR_BEFORE_READD + answer = MsgBox(" . ?", vbYesNo + vbQuestion) + + Case Else + Call MsgBox("Invalid message code", vbCritical) + End Select + UIAskQuestion = answer = vbYes +End Function diff --git a/src/aggregator/z_UIRibbon.bas b/src/aggregator/z_UIRibbon.bas new file mode 100644 index 0000000..67226b7 --- /dev/null +++ b/src/aggregator/z_UIRibbon.bas @@ -0,0 +1,12 @@ +Attribute VB_Name = "z_UIRibbon" +' +Option Explicit + +Sub OnRibbonBtn(iControl As IRibbonControl) + Select Case iControl.ID + Case "ImportExcel": Call RunImportExcel + Case "ImportWord": Call RunImportWord + Case "FollowLink": Call RunFollowLink + Case "ClearAll": Call RunClearAll + End Select +End Sub diff --git a/src/common/InfoCategory.cls b/src/common/InfoCategory.cls new file mode 100644 index 0000000..571f8df --- /dev/null +++ b/src/common/InfoCategory.cls @@ -0,0 +1,97 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "InfoCategory" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public id_ As Long +Public name_ As String +Public info_ As String +Public style_ As String +Public composition_ As Scripting.Dictionary + +Private Sub Class_Initialize() + Set composition_ = New Scripting.Dictionary +End Sub + +Public Function InitBasic(nID&, sName$, Optional sInfo$ = "") + id_ = nID + name_ = sName + info_ = sInfo +End Function + +Public Function Clone() As InfoCategory + Set Clone = New InfoCategory + With Clone + .id_ = id_ + .name_ = name_ + .info_ = info_ + .style_ = style_ + End With + + Dim iBasic As Variant + For Each iBasic In composition_ + Call Clone.composition_.Add(iBasic, composition_(iBasic)) + Next iBasic +End Function + +Public Property Get IsCombo() As Boolean + IsCombo = composition_.Count > 1 +End Property + +Public Property Get IsComplete() As Boolean + IsComplete = style_ <> vbNullString +End Property + +Public Function ImportComposition(sComposition$) As Boolean + ImportComposition = False + + Call composition_.RemoveAll + Dim sPart As Variant + For Each sPart In VBA.Split(sComposition, SPLITTER_COMPOSITION) + Dim sID$: sID = Trim(sPart) + If Not IsNumeric(sID) Then _ + Exit Function + Call composition_.Add(VBA.CLng(sID), 0) + Next sPart + + ImportComposition = True +End Function + +Public Function GetCompositionString() As String + Dim sComposition$: sComposition = "" + Dim catID As Variant + For Each catID In composition_ + If sComposition <> "" Then _ + sComposition = sComposition & SPLITTER_COMPOSITION & " " + sComposition = sComposition & catID + Next catID + GetCompositionString = sComposition +End Function + +Public Function GetFormat(iDoc As Word.Document) As InfoFormat + If Not IsComplete Then _ + Exit Function + Dim frs As New InfoFormat: Call frs.InitFromWordDiff(iDoc.Styles(wdStyleNormal), iDoc.Styles(style_)) + Set GetFormat = frs +End Function + +Public Function IsIncludedIn(anotherCat As InfoCategory) As Boolean + If Not IsCombo Then + IsIncludedIn = anotherCat.composition_.Exists(id_) + Exit Function + End If + + IsIncludedIn = False + Dim iBasic As Variant + For Each iBasic In composition_ + If Not anotherCat.composition_.Exists(iBasic) Then _ + Exit Function + Next iBasic + IsIncludedIn = True +End Function diff --git a/src/common/InfoConfig.cls b/src/common/InfoConfig.cls new file mode 100644 index 0000000..6734d0d --- /dev/null +++ b/src/common/InfoConfig.cls @@ -0,0 +1,466 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "InfoConfig" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'================ - ========================= +Option Explicit + +Public sourcePath_ As String +Public hash_ As Long + +Public categories_ As Scripting.Dictionary ' map of (catID, InfoCategory) + +Private nextID_ As Long + +Private Sub Class_Initialize() + Set categories_ = New Scripting.Dictionary + nextID_ = 1 +End Sub + +Public Property Get IsLoaded() As Boolean + IsLoaded = sourcePath_ <> "" +End Property + +Public Function Load(sFileName$) As Boolean + Load = False + + Dim fso As New Scripting.FileSystemObject + If Not fso.FileExists(sFileName) Then _ + Exit Function + + Dim wrapper As New API_WordWrapper + Call wrapper.CreateApplication(bIsVisible:=False) + Dim theDoc As Word.Document: Set theDoc = wrapper.OpenDocument(sFileName, bReadOnly:=True, bTrackMRU:=False) + If theDoc Is Nothing Then _ + Exit Function + If theDoc.Tables.Count = 0 Then + Call wrapper.ReleaseDocument + Exit Function + End If + + Load = ScanCategories(theDoc.Tables(1)) + If Load Then + sourcePath_ = sFileName + Call UpdateHash + End If + + Call wrapper.ReleaseDocument + + Load = True +End Function + +Public Function Contains(catID&) As Boolean + Contains = categories_.Exists(catID) +End Function + +Public Function GetAt(catID&) As InfoCategory + If Contains(catID) Then _ + Set GetAt = categories_(catID) +End Function + +Public Function CountIncomplete() As Long + Dim iCat As InfoCategory + Dim catID As Variant + For Each catID In categories_ + Set iCat = categories_(catID) + If Not iCat.IsComplete Then _ + CountIncomplete = CountIncomplete + 1 + Next catID +End Function + +Public Function CountCombos() As Long + Dim iCat As InfoCategory + Dim catID As Variant + For Each catID In categories_ + Set iCat = categories_(catID) + If iCat.IsCombo Then _ + CountCombos = CountCombos + 1 + Next catID +End Function + +' Throws: ERR_CAT_NAME_TAKEN +Public Function AddBasicCategory(sName$, Optional sInfo$ = "") As InfoCategory + If sName = vbNullString Then _ + Exit Function + If Not FindName(sName) Is Nothing Then _ + Call Err.Raise(ERR_CAT_NAME_TAKEN, Source:=sName) + + Dim newCat As New InfoCategory: Call newCat.InitBasic(nextID_, sName, sInfo) + nextID_ = nextID_ + 1 + Call categories_.Add(newCat.id_, newCat) + Call UpdateHash + Set AddBasicCategory = newCat +End Function + +' Throws: ERR_CAT_NAME_TAKEN, ERR_COMBO_TAKEN, ERR_UNKNOWN_CAT_ID +Public Function AddCombinedCategory(sName$, iArguments As Scripting.Dictionary, Optional sInfo$ = "") As InfoCategory + Dim existingCombo As InfoCategory: Set existingCombo = FindComposition(iArguments) + If Not existingCombo Is Nothing Then _ + Call Err.Raise(ERR_COMBO_TAKEN, existingCombo.id_) + + Dim iComposition As Scripting.Dictionary: Set iComposition = ReduceComposition(iArguments) + If iComposition Is Nothing Then _ + Call Err.Raise(ERR_UNKNOWN_CAT_ID) + + Dim iNewCat As InfoCategory: Set iNewCat = AddBasicCategory(sName, sInfo) + If iNewCat Is Nothing Then _ + Exit Function + + Set iNewCat.composition_ = iComposition + + Call UpdateHash + Set AddCombinedCategory = iNewCat +End Function + +Public Function EraseCategory(targetID&) As Boolean + EraseCategory = InternalErase(targetID) + If Not EraseCategory Then _ + Exit Function + + Dim toDelete As New Collection + Dim iCat As InfoCategory + Dim catID As Variant + For Each catID In categories_ + Set iCat = categories_(catID) + If iCat.composition_.Exists(targetID) Then _ + Call toDelete.Add(catID) + Next catID + + For Each catID In toDelete + Call InternalErase(CStr(catID)) + Next catID + Call UpdateHash +End Function + +Public Function ReduceComposition(iCats As Scripting.Dictionary) As Scripting.Dictionary + Dim iComp As New Scripting.Dictionary + Dim catID As Variant + For Each catID In iCats + Dim iCat As InfoCategory: Set iCat = GetAt(CLng(catID)) + If iCat Is Nothing Then _ + Exit Function + If iCat.IsCombo Then + Dim catElement As Variant + For Each catElement In iCat.composition_ + iComp(catElement) = 0 + Next catElement + Else + iComp.Item(catID) = 0 + End If + Next catID + Set ReduceComposition = iComp +End Function + +Public Function GetChildrenOf(targetID&) As Scripting.Dictionary + Dim iParent As InfoCategory: Set iParent = GetAt(targetID) + If iParent Is Nothing Then _ + Exit Function + + Dim iChildren As New Scripting.Dictionary + Dim catID As Variant + Dim iCat As InfoCategory + For Each catID In categories_ + If catID <> targetID Then + Set iCat = categories_(catID) + If iParent.IsIncludedIn(iCat) Then _ + Call iChildren.Add(catID, 0) + End If + Next catID + Set GetChildrenOf = iChildren +End Function + +' Throws: ERR_STYLE_TAKEN, ERR_FORMAT_TAKEN, ERR_STYLE_NO_FORMAT +Public Function AssignStyle(targetID&, wStyle As Word.Style, iDoc As Word.Document) As Boolean + AssignStyle = False + Dim target As InfoCategory: Set target = GetAt(targetID) + If target Is Nothing Then _ + Exit Function + If target.style_ = wStyle.NameLocal Then _ + Exit Function + If Not FindStyle(wStyle.NameLocal) Is Nothing Then _ + Call Err.Raise(ERR_STYLE_TAKEN) + + Dim iFormat As New InfoFormat: Call iFormat.InitFromWordDiff(iDoc.Styles(wdStyleNormal), wStyle) + If iFormat.IsEmpty Then _ + Call Err.Raise(ERR_STYLE_NO_FORMAT, Source:=wStyle.NameLocal) + + Dim iClone As InfoCategory: Set iClone = FindFormat(iFormat, iDoc) + If Not iClone Is Nothing Then _ + If iClone.id_ <> targetID Then _ + Call Err.Raise(ERR_FORMAT_TAKEN, Source:=iClone.name_) + + If iDoc.FullName <> sourcePath_ Then _ + Call WordCopyStyle(iDoc.Application, iDoc.FullName, sourcePath_, wStyle.NameLocal) + target.style_ = wStyle.NameLocal + + Call UpdateHash + AssignStyle = True +End Function + +' Throws ERR_INCOMPLETE_COMPOSITION, ERR_CANNOT_ADD_STYLE +Public Function CreateStyle(targetID&, sStyleName$, iDoc As Word.Document) As Boolean + CreateStyle = False + Dim target As InfoCategory: Set target = GetAt(targetID) + If target Is Nothing Then _ + Exit Function + If target.IsComplete Or Not target.IsCombo Then _ + Exit Function + + Dim iCombo As New Collection + Dim parentID As Variant + Dim iParent As InfoCategory + For Each parentID In target.composition_ + Set iParent = GetAt(CLng(parentID)) + If Not iParent.IsComplete Then _ + Call Err.Raise(ERR_INCOMPLETE_COMPOSITION) + Call iCombo.Add(iDoc.Styles(iParent.style_)) + Next parentID + + Dim newStyle As Word.Style: Set newStyle = CreateStyleCombination(sStyleName, iCombo, iDoc) + If newStyle Is Nothing Then _ + Call Err.Raise(ERR_CANNOT_ADD_STYLE) + + If iDoc.FullName <> sourcePath_ Then _ + Call WordCopyStyle(iDoc.Application, iDoc.FullName, sourcePath_, newStyle.NameLocal) + target.style_ = newStyle.NameLocal + + Call UpdateHash + CreateStyle = True +End Function + +Public Function FindStyle(sStyle$) As InfoCategory + Dim iCat As InfoCategory + Dim catID As Variant + For Each catID In categories_ + Set iCat = categories_(catID) + If iCat.style_ = sStyle Then + Set FindStyle = iCat + Exit Function + End If + Next catID +End Function + +Public Function FindName(sName$) As InfoCategory + Dim iCat As InfoCategory + Dim catID As Variant + For Each catID In categories_ + Set iCat = categories_(catID) + If iCat.name_ = sName Then + Set FindName = iCat + Exit Function + End If + Next catID +End Function + +Public Function FindComposition(iComposition As Scripting.Dictionary) As InfoCategory + If iComposition.Count = 0 Then _ + Exit Function + + Dim iBasicComp As Scripting.Dictionary: Set iBasicComp = ReduceComposition(iComposition) + If iBasicComp Is Nothing Then _ + Exit Function + + Dim iCat As InfoCategory + Dim catID As Variant + For Each catID In categories_ + Set iCat = categories_(catID) + If CompareDeep(iBasicComp, iCat.composition_) = 0 Then + Set FindComposition = iCat + Exit Function + End If + Next catID +End Function + +Public Function FindFormat(iTarget As InfoFormat, iDoc As Word.Document) As InfoCategory + Dim catID As Variant + For Each catID In categories_ + Dim iCat As InfoCategory: Set iCat = categories_(catID) + Dim iFormat As InfoFormat: Set iFormat = iCat.GetFormat(iDoc) + If Not iFormat Is Nothing Then + If iTarget.Compare(iFormat) = 0 Then + Set FindFormat = iCat + Exit Function + End If + End If + Next catID +End Function + +Public Function SyncDocument(target As Word.Document) + If hash_ <> GetMetadata(target, VAR_HASH) Or sourcePath_ <> GetMetadata(target, VAR_MUPATH) Then + Call SyncStyles(target.Application, target.FullName) + Call SetMetadata(target, VAR_HASH, hash_) + Call SetMetadata(target, VAR_MUPATH, sourcePath_) + End If +End Function + +Public Function SyncStyles(wordApp As Word.Application, sDestination$) + Dim catID As Variant + For Each catID In categories_ + Dim iCat As InfoCategory: Set iCat = categories_(catID) + If iCat.IsComplete Then _ + Call WordCopyStyle(wordApp, sourcePath_, sDestination, iCat.style_) + Next catID +End Function + +Public Function SaveAs(outPath$) As Boolean + SaveAs = False + + Dim wrapper As New API_WordWrapper + Dim outDoc As Word.Document: Set outDoc = wrapper.OpenDocument(outPath, bReadOnly:=False) + If outDoc Is Nothing Then _ + Exit Function + + Call SyncStyles(wrapper.Application, outPath) + sourcePath_ = outPath + + Call InternalSaveTo(outDoc) + Call wrapper.ReleaseDocument + + SaveAs = True +End Function + +Public Function Save() As Boolean + Save = False + + Dim wrapper As New API_WordWrapper + Dim outDoc As Word.Document: Set outDoc = wrapper.OpenDocument(sourcePath_, bReadOnly:=False) + If outDoc Is Nothing Then _ + Exit Function + + Call InternalSaveTo(outDoc) + Call wrapper.ReleaseDocument + + Save = True +End Function + +' ========= +Private Function InternalErase(targetID&) As Boolean + InternalErase = categories_.Exists(targetID) + If InternalErase Then _ + Call categories_.Remove(targetID) +End Function + +Private Function ScanCategories(iSource As Word.Table) + ScanCategories = False + + Call categories_.RemoveAll + + Dim nRow& + Dim iCat As InfoCategory + For nRow = WORD_FIRST_ROW To iSource.Rows.Count Step 1 + Dim sID$: sID = TrimWhitespace(iSource.Cell(nRow, WORD_CAT_ID).Range.Text) + If Not IsNumeric(sID) Then _ + Exit Function + + Set iCat = New InfoCategory + With iCat + .id_ = VBA.CLng(sID) + .name_ = TrimWhitespace(iSource.Cell(nRow, WORD_CAT_NAME).Range.Text) + .info_ = TrimWhitespace(iSource.Cell(nRow, WORD_CAT_INFO).Range.Text) + .style_ = TrimWhitespace(iSource.Cell(nRow, WORD_CAT_STYLE).Range.Text) + End With + Dim sComp$: sComp = TrimWhitespace(iSource.Cell(nRow, WORD_CAT_COMP).Range.Text) + If Not iCat.ImportComposition(sComp) Then _ + Exit Function + + Call categories_.Add(iCat.id_, iCat) + + If nextID_ <= iCat.id_ Then _ + nextID_ = iCat.id_ + 1 + Next nRow + + ScanCategories = True +End Function + +Private Function InternalSaveTo(outDoc As Word.Document) + Call PrepareOutput(outDoc) + Call OutputCategories(outDoc.Tables(1)) + Call outDoc.Save +End Function + +Private Function PrepareOutput(target As Word.Document) + Dim catTable As Word.Table + If target.Tables.Count = 0 Then + target.Sections(1).PageSetup.Orientation = wdOrientLandscape + Call target.Range.InsertParagraphAfter + Set catTable = target.Tables.Add(target.Paragraphs.Last.Range, 1, 5) + With catTable + .Cell(1, WORD_CAT_ID).Range = "ID" + .Cell(1, WORD_CAT_NAME).Range = "" + .Cell(1, WORD_CAT_STYLE).Range = "" + .Cell(1, WORD_CAT_INFO).Range = "" + .Cell(1, WORD_CAT_COMP).Range = "" + + .Borders.InsideLineStyle = wdLineStyleSingle + .Borders.OutsideLineStyle = wdLineStyleDouble + End With + Else + Set catTable = target.Tables(1) + End If + + Do While catTable.Rows.Count <> 1 + Call catTable.Rows.Last.Delete + Loop +End Function + +Private Function OutputCategories(target As Word.Table) + Dim outDoc As Word.Document: Set outDoc = target.Range.Document + Dim iCat As InfoCategory + For Each iCat In categories_ + Dim newRow As Word.Row: Set newRow = target.Rows.Add + With newRow + .Cells(WORD_CAT_ID).Range = iCat.id_ + .Cells(WORD_CAT_NAME).Range = iCat.name_ + .Cells(WORD_CAT_STYLE).Range = iCat.style_ + .Cells(WORD_CAT_INFO).Range = iCat.info_ + .Cells(WORD_CAT_COMP).Range = iCat.GetCompositionString + If iCat.IsComplete Then _ + .Cells(WORD_CAT_STYLE).Range.Style = iCat.style_ + End With + Next iCat +End Function + +Private Function CreateStyleCombination(sStyle$, iCombo As Collection, iDoc As Word.Document) As Word.Style + If WordStyleExists(iDoc, sStyle) Then _ + Exit Function + + Dim iFormat As New InfoFormat + Dim iArgFormat As InfoFormat + Dim iArg As Word.Style + For Each iArg In iCombo + Set iArgFormat = New InfoFormat: Call iArgFormat.InitFromWordDiff(iDoc.Styles(wdStyleNormal), iArg) + If Not iFormat.IsCompatibleWith(iArgFormat) Then _ + Exit Function + Call iFormat.MergeWith(iArgFormat) + Next iArg + + Dim sResult As Word.Style: Set sResult = iDoc.Styles.Add(sStyle$, wdStyleTypeCharacter) + Call iFormat.ApplyToWordFont(sResult.Font) + Set CreateStyleCombination = sResult +End Function + +Private Function UpdateHash() + hash_ = 1 + Dim nCount&: nCount = 1 + + Dim catID As Variant + Dim iCat As InfoCategory + For Each catID In categories_ + Set iCat = categories_(catID) + hash_ = (hash_ + HashName(iCat.style_) + nCount + HashName(iCat.id_)) Mod 69208103 * 31& + nCount = nCount + 1 + Next catID +End Function + +Private Function HashName(sName$) As Long + HashName = 1 + Dim nChar& + For nChar = 1 To VBA.Len(sName) + HashName = (HashName + VBA.AscW(VBA.Mid(sName, nChar, 1))) Mod 69208103 * 31& + Next nChar +End Function diff --git a/src/common/InfoDocument.cls b/src/common/InfoDocument.cls new file mode 100644 index 0000000..fb80599 --- /dev/null +++ b/src/common/InfoDocument.cls @@ -0,0 +1,338 @@ +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 + +Private Enum PuncType + PT_NONE = 0 + PT_END = 1 + PT_CONTINUATION = 2 +End Enum + +Public doc_ As Word.Document +Public markup_ As MarkupAPI + +Public Function Init(iDoc As Word.Document, iMarkup As MarkupAPI) + Set doc_ = iDoc + Set markup_ = iMarkup +End Function + +Public Function SyncStyles() + Call markup_.SyncWord(doc_) +End Function + +Public Function GetFormatIterator(catID&, Optional nStart& = 0) As IteratorFormat +' , + If Not markup_.config_.Contains(catID) Then _ + Exit Function + Dim iCat As InfoCategory: Set iCat = markup_.config_.GetAt(catID) + If Not iCat.IsComplete Then _ + Exit Function + If nStart > doc_.Range.End Then _ + Exit Function + + Set GetFormatIterator = New IteratorFormat + Call GetFormatIterator.Init(doc_, iCat.GetFormat(doc_), nStart) +End Function + +Public Function GetPreciseIterator(catID&, Optional nStart& = 0) As IteratorStyle +' + If Not markup_.config_.Contains(catID) Then _ + Exit Function + Dim iCat As InfoCategory: Set iCat = markup_.config_.GetAt(catID) + If Not iCat.IsComplete Then _ + Exit Function + If nStart > doc_.Range.End Then _ + Exit Function + + Dim cStyles As New Collection + Call cStyles.Add(iCat.style_) + Set GetPreciseIterator = New IteratorStyle + Call GetPreciseIterator.Init(doc_, cStyles, nStart) +End Function + +Public Function GetStylesIterator(catID&, Optional nStart& = 0) As IteratorStyle +' + If Not markup_.config_.Contains(catID) Then _ + Exit Function + Dim iCat As InfoCategory: Set iCat = markup_.config_.GetAt(catID) + If Not iCat.IsComplete Then _ + Exit Function + If nStart > doc_.Range.End Then _ + Exit Function + + Dim cStyles As New Collection + Call cStyles.Add(iCat.style_) + Dim aCat As InfoCategory + For Each aCat In markup_.config_.GetChildrenOf(catID) + Call cStyles.Add(aCat.style_) + Next aCat + + Set GetStylesIterator = New IteratorStyle + Call GetStylesIterator.Init(doc_, cStyles, nStart) +End Function + +Public Function ApplyCategory(iCat As InfoCategory, ByRef target As Word.Range) As Boolean + ApplyCategory = False + + If Not iCat.IsComplete Then _ + Exit Function + target.Style = iCat.style_ + + ApplyCategory = True +End Function + +Public Function ApplyFragments(iFragments As Collection) As Boolean + ApplyFragments = False + + Dim iFrag As ItemFragment + For Each iFrag In iFragments + If Not markup_.config_.Contains(iFrag.id_) Then _ + Exit Function + If Not ApplyCategory(markup_.config_.GetAt(iFrag.id_), doc_.Range(iFrag.start_, iFrag.end_)) Then _ + Exit Function + Next iFrag + + ApplyFragments = True +End Function + +Public Function AddCategory(iAddedCat As InfoCategory, ByRef target As Word.Range) As Boolean + AddCategory = False + + If Not iAddedCat.IsComplete Then _ + Exit Function + + Dim sCurrentStyle$: sCurrentStyle = target.Style.NameLocal + If sCurrentStyle = iAddedCat.style_ Then + AddCategory = True + Exit Function + End If + + Dim iCurrentCat As InfoCategory: Set iCurrentCat = markup_.config_.FindStyle(sCurrentStyle) + If iCurrentCat Is Nothing Then + target.Style = iAddedCat.style_ + AddCategory = True + Exit Function + ElseIf iCurrentCat.composition_.Exists(iAddedCat.id_) Then + AddCategory = True + Exit Function + End If + + Dim iComposition As Scripting.Dictionary: Set iComposition = CSet(iAddedCat.id_, iCurrentCat.id_) + Dim iCombo As InfoCategory: Set iCombo = markup_.config_.FindComposition(iComposition) + If Not iCombo Is Nothing Then + target.Style = iCombo.style_ + AddCategory = True + Exit Function + End If +End Function + +Public Function SetCategoryVisible(catID&, bShow As Boolean) + Dim iter As IteratorFormat: Set iter = GetFormatIterator(catID) + If iter Is Nothing Then _ + Exit Function + Do While Not iter.MoveNext Is Nothing + Dim rFragment As Word.Range: Set rFragment = FixFragment(iter.Range) + rFragment.Font.Hidden = Not bShow + Loop +End Function + +Public Function SetCategoryHighlight(catID&, bHighlight As Boolean) + Dim iter As IteratorFormat: Set iter = GetFormatIterator(catID) + If iter Is Nothing Then _ + Exit Function + Do While Not iter.MoveNext Is Nothing + Dim rFragment As Word.Range: Set rFragment = iter.Range + rFragment.HighlightColorIndex = IIf(bHighlight, wdYellow, wdNoHighlight) + Loop +End Function + +Public Function GetAllHighlights() As Collection ' of ItemFragment + Set GetAllHighlights = New Collection + Dim rFind As Word.Range: Set rFind = doc_.Range(0, 0) + With rFind.Find + .ClearFormatting + .Highlight = True + End With + With rFind + Do While .Find.Execute + Dim aFrag As New ItemFragment + aFrag.id_ = .HighlightColorIndex + aFrag.start_ = .Start + aFrag.end_ = .End + Call GetAllHighlights.Add(aFrag.Clone) + Loop + End With +End Function + +Public Function GetBasicFragmentsCompound() As Collection ' of ItemFragment + Dim catIntervals As New Scripting.Dictionary + + Dim iCat As InfoCategory + Dim catID As Variant + For Each catID In markup_.config_.categories_ + Set iCat = markup_.config_.categories_(catID) + If Not iCat.IsCombo Then _ + Set catIntervals.Item(catID) = New CDS_CompoundIntervals + Next catID + + Dim allFrags As Collection: Set allFrags = GetAllFragments() + Dim aFrag As ItemFragment + For Each aFrag In allFrags + Set iCat = markup_.config_.GetAt(aFrag.id_) + If Not iCat.IsCombo Then + Call catIntervals(iCat.id_).AddItem(aFrag.start_, aFrag.end_) + Else + Dim comboItem As Variant + For Each comboItem In iCat.composition_ + Call catIntervals(comboItem).AddItem(aFrag.start_, aFrag.end_) + Next comboItem + End If + Next aFrag + + Dim cResult As New Collection + For Each catID In markup_.config_.categories_ + Set iCat = markup_.config_.categories_(catID) + If Not iCat.IsCombo Then + Dim interval As CDS_Interval + For Each interval In catIntervals(catID).items_ + Set aFrag = New ItemFragment + aFrag.id_ = catID + aFrag.start_ = interval.start_ + aFrag.end_ = interval.finish_ + Call cResult.Add(aFrag) + Next interval + End If + Next catID + + Set GetBasicFragmentsCompound = cResult +End Function + +Public Function GetAllFragments() As Collection ' of ItemFragment + Set GetAllFragments = New Collection + Dim catID As Variant + For Each catID In markup_.config_.categories_ + Call InternalFragments(GetAllFragments, CLng(catID)) + Next catID +End Function + +' ============ +Private Function InternalFragments(ByRef out As Collection, catID&) + Dim aFrag As New ItemFragment + aFrag.id_ = catID + Dim iter As IteratorStyle: Set iter = GetPreciseIterator(catID) + Do While Not iter.MoveNext Is Nothing + aFrag.start_ = iter.Range.Start + aFrag.end_ = iter.Range.End + Call out.Add(aFrag.Clone) + Loop +End Function + +Private Function FixFragment(target As Word.Range) As Word.Range + Dim rCurrent As Word.Range: Set rCurrent = WordAdjustRange(target) + Set FixFragment = rCurrent ' Note: alias, not copy! + + Dim rightB As ItemFragment: Set rightB = GetRightBoundary(target) + Dim leftB As ItemFragment: Set leftB = GetLeftBoundary(target) + If rightB Is Nothing Or leftB Is Nothing Then _ + Exit Function + + If rightB.id_ = PT_NONE Or leftB.id_ = PT_NONE Then + If rightB.id_ = leftB.id_ Then + rCurrent.Start = leftB.start_ + rCurrent.End = rightB.end_ + End If + ElseIf leftB.id_ = PT_END Then + rCurrent.End = rightB.end_ + ElseIf leftB.id_ = rightB.id_ Then + rCurrent.Start = leftB.start_ + rCurrent.End = rightB.end_ + Else + rCurrent.Start = leftB.start_ + End If +End Function + +Private Function GetLeftBoundary(target As Word.Range) As ItemFragment + If target.Start = 0 Then _ + Exit Function + + Dim tRange As Word.Range: Set tRange = target.Duplicate + Call tRange.Collapse(wdCollapseStart) + Call tRange.MoveStart(wdWord, -1) + Dim Result As New ItemFragment + Result.end_ = tRange.End + Result.start_ = tRange.Start + + Dim sText$: sText = Trim(tRange.Text) + If sText Like "[" + Endings + "]" Then + Result.id_ = PT_END + Set GetLeftBoundary = Result + Exit Function + End If + + If sText Like "[" + Continuations + "]" Then + Result.id_ = PT_CONTINUATION + Set GetLeftBoundary = Result + Exit Function + End If + + If sText = "(" Then + Result.id_ = PT_NONE + Set GetLeftBoundary = Result + Exit Function + End If +End Function + +Private Function GetRightBoundary(target As Word.Range) As ItemFragment + If target.End = target.Document.Range.End Then _ + Exit Function + + Dim tRange As Word.Range: Set tRange = target.Duplicate + Call tRange.Collapse(wdCollapseEnd) + Call tRange.MoveEnd(wdWord, 1) + Dim Result As New ItemFragment + Result.end_ = tRange.End + Result.start_ = tRange.Start + + Dim sText$: sText = Trim(tRange.Text) + If sText Like "[" + Endings + "]" Then + Result.id_ = PT_END + Set GetRightBoundary = Result + Exit Function + End If + + If sText Like "[" + Continuations + "]" Then + Result.id_ = PT_CONTINUATION + Set GetRightBoundary = Result + Exit Function + End If + + If sText = ")" Then + Dim nextRight As ItemFragment: Set nextRight = GetRightBoundary(tRange) + If Not nextRight Is Nothing Then + If nextRight.id_ = PT_END Then + Result.id_ = PT_END + Result.end_ = nextRight.end_ + Set GetRightBoundary = Result + Exit Function + End If + End If + Result.id_ = PT_NONE + Set GetRightBoundary = Result + Exit Function + End If +End Function + +Private Function Continuations() As String + Continuations = ",;:-" & Chr(150) & Chr(151) +End Function + +Private Function Endings() As String + Endings = ".?!" & Chr(13) +End Function diff --git a/src/common/InfoFormat.cls b/src/common/InfoFormat.cls new file mode 100644 index 0000000..1d037c9 --- /dev/null +++ b/src/common/InfoFormat.cls @@ -0,0 +1,132 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "InfoFormat" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'================ ========================= +Option Explicit + +Public Enum TFormatFeature + T_FF_INVALID = 0 + [_First] = 1 + T_FF_FONT_NAME = 1 + T_FF_FONT_SIZE + T_FF_TEXT_COLOR + T_FF_BG_COLOR + T_FF_BOLD + T_FF_STRIKETHROUGH + T_FF_ITALIC + T_FF_UNDERLINE + T_FF_UNDERLINE_COLOR + T_FF_ALLCAPS + [_Last] = 10 +End Enum + +Public features_ As Scripting.Dictionary + +Private Sub Class_Initialize() + Set features_ = New Scripting.Dictionary +End Sub + +Public Function Clone() As InfoFormat + Set Clone = New InfoFormat + Dim aKey As Variant + For Each aKey In features_ + Call Clone.features_.Add(aKey, features_(aKey)) + Next aKey +End Function + +Public Function InitFromWord(wStyle As Word.Style) + Call ClearFeatures + + Dim nFeature& + For nFeature = TFormatFeature.[_First] To TFormatFeature.[_Last] + Call features_.Add(nFeature, WordGetValue(nFeature, wStyle.Font)) + Next nFeature +End Function + +Public Function InitFromWordDiff(sBase As Word.Style, sDerived As Word.Style) + Call ClearFeatures + + Dim nFeature& + For nFeature = TFormatFeature.[_First] To TFormatFeature.[_Last] + If WordGetValue(nFeature, sBase.Font) <> WordGetValue(nFeature, sDerived.Font) Then _ + Call features_.Add(nFeature, WordGetValue(nFeature, sDerived.Font)) + Next nFeature +End Function + +Public Function IsEmpty() As Boolean + IsEmpty = features_.Count = 0 +End Function + +Public Function ApplyToWordFont(ByRef target As Word.Font) + Dim nFeature As Variant + For Each nFeature In features_ + Call WordSetValue(CLng(nFeature), target, features_(nFeature)) + Next nFeature +End Function + +Public Function Compare(rValue As InfoFormat) As Double + Compare = CompareDeep(features_, rValue.features_) +End Function + +Public Function IsCompatibleWith(rValue As InfoFormat) As Boolean + IsCompatibleWith = False + + Dim nFeature As Variant + For Each nFeature In features_ + If rValue.features_.Exists(nFeature) Then _ + If features_(nFeature) <> rValue.features_(nFeature) Then _ + Exit Function + Next nFeature + + IsCompatibleWith = True +End Function + +' !Requires IsCompatibleWith(rValue) +Public Function MergeWith(rValue As InfoFormat) + Dim nFeature As Variant + For Each nFeature In rValue.features_ + features_.Item(nFeature) = rValue.features_(nFeature) + Next nFeature +End Function + +' ========= +Private Function ClearFeatures() + Call features_.RemoveAll +End Function + +Private Function WordGetValue(nFeature As TFormatFeature, wFont As Word.Font) As Variant + Select Case nFeature + Case T_FF_FONT_NAME: WordGetValue = wFont.Name + Case T_FF_FONT_SIZE: WordGetValue = wFont.Size + Case T_FF_BOLD: WordGetValue = wFont.Bold + Case T_FF_ITALIC: WordGetValue = wFont.Italic + Case T_FF_TEXT_COLOR: WordGetValue = wFont.TextColor + Case T_FF_BG_COLOR: WordGetValue = wFont.Shading.BackgroundPatternColor + Case T_FF_UNDERLINE_COLOR: WordGetValue = wFont.UnderlineColor + Case T_FF_STRIKETHROUGH: WordGetValue = wFont.StrikeThrough + Case T_FF_UNDERLINE: WordGetValue = wFont.Underline + Case T_FF_ALLCAPS: WordGetValue = wFont.AllCaps + End Select +End Function + +Private Function WordSetValue(nFeature As TFormatFeature, ByRef target As Word.Font, iValue As Variant) + Select Case nFeature + Case T_FF_FONT_NAME: target.Name = iValue + Case T_FF_FONT_SIZE: target.Size = iValue + Case T_FF_BOLD: target.Bold = iValue + Case T_FF_ITALIC: target.Italic = iValue + Case T_FF_TEXT_COLOR: target.TextColor = iValue + Case T_FF_BG_COLOR: target.Shading.BackgroundPatternColor = iValue + Case T_FF_UNDERLINE_COLOR: target.UnderlineColor = iValue + Case T_FF_STRIKETHROUGH: target.StrikeThrough = iValue + Case T_FF_UNDERLINE: target.Underline = iValue + Case T_FF_ALLCAPS: target.AllCaps = iValue + End Select +End Function + diff --git a/src/common/ItemConfigDescriptor.cls b/src/common/ItemConfigDescriptor.cls new file mode 100644 index 0000000..22d7c03 --- /dev/null +++ b/src/common/ItemConfigDescriptor.cls @@ -0,0 +1,21 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ItemConfigDescriptor" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public name_$ +Public path_$ + +Public Function Clone() As ItemConfigDescriptor + Set Clone = New ItemConfigDescriptor + With Clone + .name_ = name_ + .path_ = path_ + End With +End Function diff --git a/src/common/ItemFragment.cls b/src/common/ItemFragment.cls new file mode 100644 index 0000000..9079691 --- /dev/null +++ b/src/common/ItemFragment.cls @@ -0,0 +1,37 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ItemFragment" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public id_ As Long +Public start_ As Long +Public end_ As Long + +Public Function Init(catID&, nStart&, nEnd&) + id_ = catID + start_ = nStart + end_ = nEnd +End Function + +Public Function Clone() As ItemFragment + Set Clone = New ItemFragment + With Clone + .start_ = start_ + .end_ = end_ + .id_ = id_ + End With +End Function + +Public Function Compare(rhs As Variant) As Double + Compare = id_ - rhs.id_ + If Compare = 0 Then _ + Compare = start_ - rhs.start_ + If Compare = 0 Then _ + Compare = end_ - rhs.end_ +End Function diff --git a/src/common/IteratorFormat.cls b/src/common/IteratorFormat.cls new file mode 100644 index 0000000..535d5fe --- /dev/null +++ b/src/common/IteratorFormat.cls @@ -0,0 +1,45 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "IteratorFormat" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' +Option Explicit + +Private selection_ As Word.Range +Private format_ As InfoFormat + +Public Function Init(theDoc As Word.Document, iFormat As InfoFormat, Optional nStart& = 0) + Set format_ = iFormat + Set selection_ = theDoc.Range(nStart, nStart) +End Function + +Public Function Range() As Word.Range + Set Range = selection_ +End Function + +Public Function MoveNext() As Word.Range + Set MoveNext = IIf(Increment(True), selection_, Nothing) +End Function + +Public Function MovePrev() As Word.Range + Set MovePrev = IIf(Increment(False), selection_, Nothing) +End Function + +' ========= +Private Function Increment(bForward As Boolean) As Boolean + Dim rSearch As Word.Range: Set rSearch = selection_.Duplicate + Call rSearch.Collapse(IIf(bForward, wdCollapseEnd, wdCollapseStart)) + + Call format_.ApplyToWordFont(rSearch.Find.Font) + rSearch.Find.Format = True + rSearch.Find.Forward = bForward + Increment = rSearch.Find.Execute + If Increment Then _ + Set selection_ = rSearch +End Function + diff --git a/src/common/IteratorStyle.cls b/src/common/IteratorStyle.cls new file mode 100644 index 0000000..492a10c --- /dev/null +++ b/src/common/IteratorStyle.cls @@ -0,0 +1,109 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "IteratorStyle" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' +Option Explicit + +Private selection_ As Word.Range +Private styles_ As Collection + +Public Function Init(theDoc As Word.Document, searchWhat As Collection, Optional nStart& = 0) + Set styles_ = searchWhat + Set selection_ = theDoc.Range(nStart, nStart) +End Function + +Public Function Range() As Word.Range + Set Range = selection_ +End Function + +Public Function MoveNext() As Word.Range + Set MoveNext = IIf(Increment(True), selection_, Nothing) +End Function + +Public Function MovePrev() As Word.Range + Set MovePrev = IIf(Increment(False), selection_, Nothing) +End Function + +' ========= +Private Function Increment(bForward As Boolean) As Boolean + Increment = False + If Not IncrementOnce(bForward) Then _ + Exit Function + + Dim nStart&: nStart = selection_.Start + Dim nFinish&: nFinish = selection_.End + Do + Call IncrementOnce(bForward) + If selection_.Start <> nFinish Then _ + Exit Do + nFinish = selection_.End + Loop + + Set selection_ = selection_.Document.Range(nStart, nFinish) + Increment = True +End Function + +Private Function IncrementOnce(bForward As Boolean) + IncrementOnce = False + + Dim iFoundIntervals As New CDS_CompoundIntervals + Dim sStyle As Variant + For Each sStyle In styles_ + Dim rOption As Word.Range: Set rOption = IncrementStyle(CStr(sStyle), bForward) + If Not rOption Is Nothing Then _ + Call iFoundIntervals.AddItem(rOption.Start, rOption.End) + Next sStyle + If iFoundIntervals.IsEmpty Then _ + Exit Function + + Dim iResult As CDS_Interval: Set iResult = iFoundIntervals.items_(1) + Dim rAlt As CDS_Interval + For Each rAlt In iFoundIntervals.items_ + If bForward Then + If iResult.start_ > rAlt.start_ Then _ + Set iResult = rAlt + Else + If iResult.finish_ < rAlt.finish_ Then _ + Set iResult = rAlt + End If + Next rAlt + + Set selection_ = selection_.Document.Range(iResult.start_, iResult.finish_) + IncrementOnce = True +End Function + +Private Function IncrementStyle(sStyle$, bForward As Boolean) As Word.Range + Dim theDoc As Word.Document: Set theDoc = selection_.Document + Dim rSearch As Word.Range: Set rSearch = selection_.Duplicate + Call rSearch.Collapse(IIf(bForward, wdCollapseEnd, wdCollapseStart)) + + rSearch.Find.Forward = bForward + rSearch.Find.Style = sStyle + rSearch.Find.Format = True + If Not rSearch.Find.Execute Then _ + Exit Function + + Set IncrementStyle = rSearch.Duplicate + If rSearch.End = theDoc.Range.End Then _ + Exit Function + + + If theDoc.Range(rSearch.End, rSearch.End + 1).Text <> "" Then _ + Exit Function + + Call rSearch.Collapse(IIf(bForward, wdCollapseEnd, wdCollapseStart)) + If Not rSearch.Find.Execute Then _ + Exit Function + + If rSearch.Start = IncrementStyle.End + 1 Then _ + IncrementStyle.End = rSearch.End +End Function + + + diff --git a/src/common/MU_Declarations.bas b/src/common/MU_Declarations.bas new file mode 100644 index 0000000..3afd1a5 --- /dev/null +++ b/src/common/MU_Declarations.bas @@ -0,0 +1,65 @@ +Attribute VB_Name = "MU_Declarations" +' +' API : MU_ MarkupAPI +Option Private Module +Option Explicit + +Public Const VAR_MUPATH = "MarkupConfig" +Public Const VAR_HASH = "MarkupHash" + +Public Const CONFIG_PATH = "\Microsoft\\\" +Public Const CONFIG_MASK = "*.docx" + +Public Const WORD_FIRST_ROW = 2 + +Public Const WORD_CAT_ID = 1 +Public Const WORD_CAT_NAME = 2 +Public Const WORD_CAT_STYLE = 3 +Public Const WORD_CAT_INFO = 4 +Public Const WORD_CAT_COMP = 5 + +Public Const SPLITTER_COMPOSITION = ";" +Public Const INFO_GENERATED = "GENERATED" + +Public Enum OutExcelStruct + OES_ID = 1 + OES_START = 2 + OES_FINISH = 3 + OES_TYPE = 4 + OES_TEXT = 5 + OES_COMMENT = 6 + OES_SOURCE_LABEL = 7 + OES_SOURCE = 8 +End Enum + +' Markup errors +Public Enum MUErrors + ERR_COMBO_TAKEN = vbObjectError + 1000 + ERR_CANNOT_ADD_STYLE + ERR_STYLE_TAKEN + ERR_FORMAT_TAKEN + ERR_UNKNOWN_CAT_ID + ERR_CAT_NAME_TAKEN + ERR_STYLE_NO_FORMAT + ERR_INCOMPLETE_COMPOSITION +End Enum + +Public Function Markup() As MarkupAPI + Static globalMarkup As New MarkupAPI + Set Markup = globalMarkup +End Function + +Public Function GetConfigList() As Collection + Set GetConfigList = New Collection + + Dim fso As New Scripting.FileSystemObject + Dim desc As New ItemConfigDescriptor + Dim sFolder$: sFolder = VBA.Environ("AppData") & CONFIG_PATH + Dim sFile$: sFile = sFolder & VBA.Dir(sFolder & CONFIG_MASK) + Do While sFile <> sFolder + desc.path_ = sFile + desc.name_ = fso.GetBaseName(desc.path_) + Call GetConfigList.Add(desc.Clone()) + sFile = sFolder & VBA.Dir + Loop +End Function diff --git a/src/common/MarkupAPI.cls b/src/common/MarkupAPI.cls new file mode 100644 index 0000000..5760e16 --- /dev/null +++ b/src/common/MarkupAPI.cls @@ -0,0 +1,87 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "MarkupAPI" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'================ API ========================= +Option Explicit + +Public config_ As InfoConfig + +Private Sub Class_Initialize() + Set config_ = New InfoConfig +End Sub + +Public Function LoadConfig(sConfig$) As Boolean + LoadConfig = config_.Load(sConfig) +End Function + +Public Function InitFromCurrentDocument(target As Word.Document) As Boolean + InitFromCurrentDocument = False + + Dim sConfig$: sConfig = GetMetadata(target, VAR_MUPATH) + If sConfig = "" Then _ + Exit Function + + InitFromCurrentDocument = LoadConfig(sConfig) + If InitFromCurrentDocument Then + Call config_.SyncDocument(target) + Else + Call SetMetadata(target, VAR_MUPATH, "") + Call SetMetadata(target, VAR_HASH, "") + End If +End Function + +Public Function ValidateConfig(styleDoc As Word.Document) As String + Dim sLog$ + Dim errCount& + Dim iCat As InfoCategory + Dim catID As Variant + For Each catID In config_.categories_ + Set iCat = config_.categories_(catID) + If Not iCat.IsComplete Then + errCount = errCount + 1 + sLog = sLog & " : " & iCat.name_ & vbNewLine + Else + errCount = errCount + CheckStyleSimilarity(sLog, iCat, styleDoc) + End If + Next catID + + If errCount = 0 Then + ValidateConfig = " " + Else + ValidateConfig = " " & vbNewLine & VBA.Right(sLog, VBA.Len(sLog) - 1) + End If +End Function + +Public Function SyncWord(target As Word.Document) As Boolean + SyncWord = False + If Not config_.IsLoaded Then _ + Exit Function + + Call config_.SyncDocument(target) + + SyncWord = True +End Function + +' =========== +Private Function CheckStyleSimilarity(ByRef sLog$, iCat1 As InfoCategory, styleDoc As Word.Document) As Long + Dim iCat2 As InfoCategory + Dim catID As Variant + For Each catID In config_.categories_ + Set iCat2 = config_.categories_(catID) + If iCat2.style_ = "" Or iCat1.id_ = iCat2.id_ Then _ + GoTo NEXT_CAT + + Dim frs As New InfoFormat: Call frs.InitFromWordDiff(styleDoc.Styles(iCat1.style_), styleDoc.Styles(iCat2.style_)) + If frs.IsEmpty Then + CheckStyleSimilarity = CheckStyleSimilarity + 1 + sLog = sLog & " : " & iCat1.style_ & " == " & iCat2.style_ & vbNewLine + End If +NEXT_CAT: + Next catID +End Function diff --git a/src/markup/Declarations.bas b/src/markup/Declarations.bas new file mode 100644 index 0000000..ee676a0 --- /dev/null +++ b/src/markup/Declarations.bas @@ -0,0 +1,8 @@ +Attribute VB_Name = "Declarations" +Option Explicit + +Public Const APP_HELP = "\\fs1.concept.ru\projects\10 \01 \-\! .docx" + +Public Const TEMP_FILE_NAME = "conceptMarkup" + +Public Const DATA_ROW_START = 2 diff --git a/src/markup/DevHelper.bas b/src/markup/DevHelper.bas new file mode 100644 index 0000000..bad2162 --- /dev/null +++ b/src/markup/DevHelper.bas @@ -0,0 +1,52 @@ +Attribute VB_Name = "DevHelper" +Option Explicit + +Private Const TEST_SOURCES = "test" +Private Const TEST_CONFIG = "TestConfig.docx" + +Private Const TEST_FILES = "testFiles" + +Public Function Dev_PrepareSkeleton() + ' Do nothing +End Function + +Public Sub Dev_ManualRunTest() + Dim sSuite$: sSuite = "s_WordDocument" + Dim sTest$: sTest = "t_AddCategory" + Dim sMsg$: sMsg = Dev_RunTestDebug(sSuite, sTest) + Debug.Print sMsg + Call MsgBox(sMsg) +End Sub + +Public Function Dev_GetTestSuite(sName$) As Object + Select Case sName + Case "s_WordDocument": Set Dev_GetTestSuite = New s_WordDocument + Case "s_MarkupAPI": Set Dev_GetTestSuite = New s_MarkupAPI + Case "s_Format": Set Dev_GetTestSuite = New s_Format + Case "s_Category": Set Dev_GetTestSuite = New s_Category + Case "s_Config": Set Dev_GetTestSuite = New s_Config + End Select +End Function + +Public Function GetTestFolder() As String + Dim fso As New Scripting.FileSystemObject + GetTestFolder = fso.GetParentFolderName(ThisDocument.Path) + GetTestFolder = GetTestFolder & "\" & TEST_FILES +End Function + +Public Function ResetTestFolder() + Dim sFolder$: sFolder = GetTestFolder + Dim fso As New Scripting.FileSystemObject + On Error Resume Next + Call fso.DeleteFolder(sFolder) + On Error GoTo 0 + Call EnsureFolderExists(sFolder, fso) +End Function + +Public Function SetupTestConfig() As String + Dim fso As New Scripting.FileSystemObject + Dim sSource$: sSource = fso.GetParentFolderName(ThisDocument.Path) & "\" & TEST_SOURCES & "\" & TEST_CONFIG + Dim sTest$: sTest = GetTestFolder & "\" & TEST_CONFIG + Call fso.CopyFile(sSource, sTest) + SetupTestConfig = sTest +End Function diff --git a/src/markup/Main.bas b/src/markup/Main.bas new file mode 100644 index 0000000..b3014cc --- /dev/null +++ b/src/markup/Main.bas @@ -0,0 +1,331 @@ +Attribute VB_Name = "Main" +Option Explicit + +Public Sub MU_OpenConfig() + If Not PreloadConfig Then _ + Exit Sub + If Not UserInteraction.AskQuestion(QM_CONFIG_EDIT_CONFIRM) Then _ + Exit Sub + Dim iShell As New Shell32.Shell + Call iShell.Open(Markup.config_.sourcePath_) +End Sub + +Public Sub MU_SyncStyles() + If Not PreloadConfig Then _ + Exit Sub + Call Markup.config_.SyncStyles(ThisDocument.Application, ActiveDocument.FullName) + Call UserInteraction.ShowMessage(IM_STYLES_UPDATE_SUCCESS) +End Sub + +Public Sub MU_LoadConfig() + Dim sFile$: sFile = UserInteraction.PromptFile(ActiveDocument.Path) + If sFile = vbNullString Then _ + Exit Sub + Call MU_LoadConfigFrom(sFile) + Call UIUpdateConfigList +End Sub + +Public Function MU_LoadConfigFrom(sFile$) As Boolean + If Not Markup.config_.Load(sFile) Then + Call UserInteraction.ShowMessage(EM_EXPORT_CONFIG_FAIL) + MU_LoadConfigFrom = False + Else + Call UIResetCategories + MU_LoadConfigFrom = True + End If +End Function + +Public Sub MU_DetermineCategory() + If Not PreloadConfig Then _ + Exit Sub + + Dim iCat As InfoCategory: Set iCat = Markup.config_.FindStyle(Selection.Style) + If iCat Is Nothing Then + Call UserInteraction.ShowMessage(IM_NO_CATEGORY) + Else + Call UserInteraction.ShowMessage(IM_CATEGORY_OUT, iCat.id_, iCat.name_) + End If +End Sub + +Public Sub MU_ApplyCategory() + If Not PreloadConfig Then _ + Exit Sub + Dim iCat As InfoCategory: Set iCat = ActiveCategory + If iCat Is Nothing Then _ + Exit Sub + + Dim iDoc As InfoDocument: Set iDoc = GetActiveWrapper + Dim rSelection As Word.Range: Set rSelection = WordAdjustRange(Selection.Range) + If iDoc.ApplyCategory(iCat, rSelection) Then _ + Call rSelection.Select +End Sub + +Public Sub MU_AddCategory() + If Not PreloadConfig Then _ + Exit Sub + Dim iCat As InfoCategory: Set iCat = ActiveCategory + If iCat Is Nothing Then _ + Exit Sub + + Dim iDoc As InfoDocument: Set iDoc = GetActiveWrapper + Dim rSelection As Word.Range: Set rSelection = WordAdjustRange(Selection.Range) + If iDoc.AddCategory(iCat, rSelection) Then + Call rSelection.Select + Call UIUpdateCategories + Else + Call UserInteraction.ShowMessage(EM_CANNOT_COMBINE_STYLES) + End If +End Sub + +Public Sub MU_ClearFragment() + Dim tRange As Word.Range: Set tRange = Selection.Range.Duplicate + Dim iDoc As New InfoDocument: Call iDoc.Init(ActiveDocument, Markup) + Set tRange = WordAdjustRange(tRange) + tRange.Style = wdStyleDefaultParagraphFont + Call tRange.Select +End Sub + +Sub MU_NextCategory() + If Not PreloadConfig Then _ + Exit Sub + Call UINextCat +End Sub + +Sub MU_PrevCategory() + If Not PreloadConfig Then _ + Exit Sub + Call UIPrevCat +End Sub + +Public Sub MU_GotoNext() + If Not PreloadConfig Then _ + Exit Sub + Dim iCat As InfoCategory: Set iCat = ActiveCategory + If iCat Is Nothing Then _ + Exit Sub + + Dim iter As IteratorFormat: Set iter = GetActiveWrapper.GetFormatIterator(iCat.id_, Selection.End) + Dim rFound As Word.Range: Set rFound = iter.MoveNext + If Not rFound Is Nothing Then _ + Call rFound.Select +End Sub + +Public Sub MU_GotoPrev() + If Not PreloadConfig Then _ + Exit Sub + Dim iCat As InfoCategory: Set iCat = ActiveCategory + If iCat Is Nothing Then _ + Exit Sub + + Dim iter As IteratorFormat: Set iter = GetActiveWrapper.GetFormatIterator(iCat.id_, Selection.Start) + Dim rFound As Word.Range: Set rFound = iter.MovePrev + If Not rFound Is Nothing Then _ + Call rFound.Select +End Sub + +Public Sub MU_HideText() + If Not PreloadConfig Then _ + Exit Sub + Dim iCat As InfoCategory: Set iCat = ActiveCategory + If iCat Is Nothing Then _ + Exit Sub + + Dim wUI As New API_WordWrapper: Call wUI.SetDocument(ActiveDocument) + Call wUI.PauseUI + Call GetActiveWrapper.SetCategoryVisible(iCat.id_, False) + Call wUI.ResumeUI +End Sub + +Public Sub MU_ShowText() + If Not PreloadConfig Then _ + Exit Sub + Dim iCat As InfoCategory: Set iCat = ActiveCategory + If iCat Is Nothing Then _ + Exit Sub + + Dim wUI As New API_WordWrapper: Call wUI.SetDocument(ActiveDocument) + Call wUI.PauseUI + Call GetActiveWrapper.SetCategoryVisible(iCat.id_, True) + Call wUI.ResumeUI +End Sub + +Public Sub MU_HighlightText() + If Not PreloadConfig Then _ + Exit Sub + Dim iCat As InfoCategory: Set iCat = ActiveCategory + If iCat Is Nothing Then _ + Exit Sub + + Dim wUI As New API_WordWrapper: Call wUI.SetDocument(ActiveDocument) + Call wUI.PauseUI + Call GetActiveWrapper.SetCategoryHighlight(iCat.id_, True) + Call wUI.ResumeUI +End Sub + +Public Sub MU_UnhighlightText() + If Not PreloadConfig Then _ + Exit Sub + Dim iCat As InfoCategory: Set iCat = ActiveCategory + If iCat Is Nothing Then _ + Exit Sub + + Dim wUI As New API_WordWrapper: Call wUI.SetDocument(ActiveDocument) + Call wUI.PauseUI + Call GetActiveWrapper.SetCategoryHighlight(iCat.id_, False) + Call wUI.ResumeUI +End Sub + +Public Sub MU_ExtractVisible() + Dim iSource As Word.Document: Set iSource = ActiveDocument + + Dim wrapper As New API_WordWrapper + Dim iDestination As Word.Document: Set iDestination = wrapper.NewDocument + If iDestination Is Nothing Then _ + Exit Sub + + Call TransferVisible(iSource, iDestination) + + Call UserInteraction.ShowMessage(IM_EXPORT_VISIBLE_SUCCESS) +End Sub + +Public Sub MU_ExtractCategory() + If Not PreloadConfig Then _ + Exit Sub + + Dim iCat As InfoCategory: Set iCat = ActiveCategory + If iCat Is Nothing Then _ + Exit Sub + + Dim wrapper As New API_WordWrapper + Dim iDestination As Word.Document: Set iDestination = wrapper.NewDocument + If iDestination Is Nothing Then _ + Exit Sub + + Dim iter As IteratorFormat: Set iter = GetActiveWrapper.GetFormatIterator(iCat.id_) + Do While Not iter.MoveNext Is Nothing + Call iter.Range.Copy + Call iDestination.Range.InsertAfter(vbNewLine) + Call iDestination.Paragraphs.Last.Range.Paste + Loop + + Call UserInteraction.ShowMessage(IM_EXPORT_CATEGORY_SUCCESS) +End Sub + +Public Sub MU_ExportMarkup() + If Not PreloadConfig Then _ + Exit Sub + + Dim iDoc As InfoDocument: Set iDoc = GetActiveWrapper + + Dim outName$: outName = ActiveDocument.FullName & "_export" & ".txt" + Dim fso As New Scripting.FileSystemObject + Dim textOut As Object: Set textOut = fso.CreateTextFile(outName, True) + + Dim frags As Collection: Set frags = iDoc.GetAllFragments() + Dim aFrag As ItemFragment + For Each aFrag In frags + Call textOut.WriteLine(CStr(aFrag.start_) & vbTab & CStr(aFrag.end_) & vbTab & aFrag.id_) + Next aFrag + + Call textOut.Close + + Dim oShell As New Shell32.Shell + Call oShell.Open(outName) +End Sub + +Public Sub MU_ImportMarkup() + If Not PreloadConfig Then _ + Exit Sub + + Dim sFile$: sFile = UserInteraction.PromptFile(ActiveDocument.Path) + If sFile = "" Then _ + Exit Sub + Dim fragments As Collection: Set fragments = ScanFragmentsFrom(sFile) + If fragments Is Nothing Then _ + Exit Sub + + Dim iDoc As InfoDocument: Set iDoc = GetActiveWrapper + If iDoc.ApplyFragments(fragments) Then + Call UserInteraction.ShowMessage(IM_IMPORT_SUCCESS) + Else + Call UserInteraction.ShowMessage(EM_IMPORT_FAIL) + End If +End Sub + +Public Sub MU_ExportMarkedText() + If Not PreloadConfig Then _ + Exit Sub + + Dim iDoc As InfoDocument: Set iDoc = GetActiveWrapper + + Dim xlApp As New API_XLWrapper + Dim outWB As Excel.Workbook: Set outWB = xlApp.NewDocument + If outWB Is Nothing Then + Call UserInteraction.ShowMessage(EM_FAILED_OUTPUT_CREATION) + Exit Sub + End If + + Dim frags As Collection: Set frags = iDoc.GetBasicFragmentsCompound() + + Call CSE_ProgressBar.Init(" ", maxVal:=frags.Count) + Call CSE_ProgressBar.Show + + Call xlApp.PauseUI + Call Output2Excel(outWB, frags) + Call xlApp.ResumeUI + + Call Unload(CSE_ProgressBar) + + Call UserInteraction.ShowMessage(IM_EXCEL_OUT_SUCCESS) +End Sub + +Public Sub MU_ExportHighlights() + Dim outName$: outName = ActiveDocument.FullName & "_export" & ".txt" + Dim fso As New Scripting.FileSystemObject + Dim textOut As Object: Set textOut = fso.CreateTextFile(outName, True) + + Dim iDoc As New InfoDocument: Call iDoc.Init(ActiveDocument, Markup) + Dim frags As Collection: Set frags = iDoc.GetAllHighlights() + Dim aFrag As ItemFragment + For Each aFrag In frags + Call textOut.WriteLine(CStr(aFrag.start_) & vbTab & CStr(aFrag.end_) & vbTab & aFrag.id_) + Next aFrag + + Call textOut.Close + + Dim oShell As New Shell32.Shell + Call oShell.Open(outName) +End Sub + +Public Sub MU_ViewHelp() + Dim aWrap As New API_WordWrapper + Dim helpDoc As Word.Document: Set helpDoc = aWrap.OpenDocument(APP_HELP, bReadOnly:=True) + If helpDoc Is Nothing Then _ + Exit Sub + + helpDoc.ActiveWindow.View.ReadingLayout = False + Call helpDoc.Activate +End Sub + +' ======= +Private Function GetActiveWrapper() As InfoDocument + Dim iDoc As New InfoDocument: Call iDoc.Init(ActiveDocument, Markup) + Call iDoc.SyncStyles + Set GetActiveWrapper = iDoc +End Function + +Private Function PreloadConfig() As Boolean + PreloadConfig = False + + If Not Markup.config_.IsLoaded Then + If Not Markup.InitFromCurrentDocument(ActiveDocument) Then + Call UserInteraction.ShowMessage(EM_CONFIG_LOAD_FAIL) + Exit Function + Else + Call UIUpdateConfigList + Call UIResetCategories + End If + End If + + PreloadConfig = True +End Function diff --git a/src/markup/MainImpl.bas b/src/markup/MainImpl.bas new file mode 100644 index 0000000..30c0884 --- /dev/null +++ b/src/markup/MainImpl.bas @@ -0,0 +1,119 @@ +Attribute VB_Name = "MainImpl" +Option Explicit + +Public Function Output2Excel(outWB As Excel.Workbook, frags As Collection) + Dim dataSht As Excel.Worksheet: Set dataSht = outWB.Worksheets(1) + Call InitOutputHeader(dataSht) + Dim iPath As New API_Path: Call iPath.FromString(ActiveDocument.FullName) + + dataSht.Cells(2, OES_SOURCE_LABEL) = "" + dataSht.Cells(2, OES_SOURCE) = iPath.GlobalToServer.Text + + Dim aFrag As ItemFragment + Dim nRow&: nRow = DATA_ROW_START + For Each aFrag In frags + Dim theRange As Word.Range: Set theRange = ActiveDocument.Range(aFrag.start_, aFrag.end_) + + dataSht.Cells(nRow, OES_ID) = nRow - 1 + dataSht.Cells(nRow, OES_START) = CStr(theRange.Start) + dataSht.Cells(nRow, OES_FINISH) = CStr(theRange.End) + dataSht.Cells(nRow, OES_TYPE) = CStr(aFrag.id_) + dataSht.Cells(nRow, OES_TEXT) = theRange.Text + dataSht.Cells(nRow, OES_COMMENT) = ExtractCommentText(theRange) + + nRow = nRow + 1 + Call CSE_ProgressBar.IncrementA + Next aFrag + + On Error Resume Next + Call dataSht.Columns("A:F").Sort(key1:=dataSht.Range("B2"), order1:=xlAscending, key2:=dataSht.Range("C2"), order2:=xlDescending, Header:=xlYes) + On Error GoTo 0 +End Function + +Public Function TransferVisible(iSource As Word.Document, iDestination As Word.Document) + Call iSource.Range.Copy + Call iDestination.Paragraphs.Add + Dim nStart&: nStart = iDestination.Paragraphs.Last.Range.Start + Call iDestination.Paragraphs.Last.Range.Paste + + Dim rFind As Word.Range: Set rFind = iDestination.Range + rFind.Start = nStart + Call rFind.Find.ClearFormatting + Call rFind.Find.Replacement.ClearFormatting + With rFind.Find + .Font.Hidden = True + .MatchWildcards = True + .Text = "*" + .Replacement.Text = "" + .Forward = True + Call .Execute(Replace:=wdReplaceAll) + End With +End Function + +Public Function ScanFragmentsFrom(sFile$) As Collection + Dim fso As New Scripting.FileSystemObject + If VBA.LCase(fso.GetExtensionName(sFile)) = "txt" Then + Set ScanFragmentsFrom = ScanTextFile(sFile) + Else + Set ScanFragmentsFrom = ScanXLFile(sFile) + End If +End Function + +' ===== +Private Function InitOutputHeader(target As Excel.Worksheet) + target.Cells(1, OES_ID) = "ID" + target.Cells(1, OES_START) = "" + target.Cells(1, OES_FINISH) = "" + target.Cells(1, OES_TYPE) = "" + target.Cells(1, OES_TEXT) = "" + target.Cells(1, OES_COMMENT) = "" +End Function + +Private Function ScanTextFile(sFile$) As Collection + Dim fso As New Scripting.FileSystemObject + Dim textIn As Object: Set textIn = fso.OpenTextFile(sFile) + If textIn Is Nothing Then _ + Exit Function + + Dim fragments As New Collection + Dim frag As New ItemFragment + While Not textIn.AtEndOfStream + Dim text_line$: text_line = textIn.ReadLine + If text_line = vbNullString Then _ + GoTo EXIT_LOOP + + Dim elemArray() As String: elemArray = VBA.Split(text_line, vbTab) + frag.start_ = CLng(elemArray(0)) + frag.end_ = CLng(elemArray(1)) + frag.id_ = elemArray(2) + Call fragments.Add(frag.Clone) + Wend +EXIT_LOOP: + Call textIn.Close + Set ScanTextFile = fragments +End Function + +Private Function ScanXLFile(sFile$) As Collection + Dim xlApp As New API_XLWrapper + If xlApp.OpenDocument(sFile, bReadOnly:=True) Is Nothing Then _ + Exit Function + + On Error GoTo SAFE_EXIT + Dim fragments As New Collection + Dim frag As New ItemFragment + Dim iData As Excel.Worksheet: Set iData = xlApp.Document.Sheets(1) + Dim nRow&: nRow = DATA_ROW_START + Do While iData.Cells(nRow, OES_ID) <> vbNullString + frag.start_ = iData.Cells(nRow, OES_START) + frag.end_ = iData.Cells(nRow, OES_FINISH) + frag.id_ = iData.Cells(nRow, OES_TYPE) + Call fragments.Add(frag.Clone) + nRow = nRow + 1 + Loop + On Error GoTo 0 + +SAFE_EXIT: + Call xlApp.ReleaseDocument + Set ScanXLFile = fragments +End Function + diff --git a/src/markup/z_UIMessages.bas b/src/markup/z_UIMessages.bas new file mode 100644 index 0000000..0a45feb --- /dev/null +++ b/src/markup/z_UIMessages.bas @@ -0,0 +1,121 @@ +Attribute VB_Name = "z_UIMessages" +' Messaging module +Option Private Module +Option Explicit + +Public Enum MsgCode + EM_COMBO_TAKEN = ERR_COMBO_TAKEN + EM_CANNOT_ADD_STYLE = ERR_CANNOT_ADD_STYLE + EM_STYLE_TAKEN = ERR_STYLE_TAKEN + EM_FORMAT_TAKEN = ERR_FORMAT_TAKEN + EM_UNKNOWN_CAT_ID = ERR_UNKNOWN_CAT_ID + EM_CAT_NAME_TAKEN = ERR_CAT_NAME_TAKEN + EM_STYLE_NO_FORMAT = ERR_STYLE_NO_FORMAT + EM_INCOMPLETE_COMPOSITION = ERR_INCOMPLETE_COMPOSITION + + EM_EXPORT_CONFIG_FAIL = 1 + EM_FAILED_OUTPUT_CREATION + EM_IMPORT_FAIL + EM_CONFIG_LOAD_FAIL + EM_CANNOT_COMBINE_STYLES + EM_CONFIG_MISSING + EM_ID_NOT_SELECTED + EM_STYLE_NOT_SELECTED + EM_CATEGORY_NOT_SELECTED + EM_RIBBON_NOT_REACHABLE + EM_VALIDATION_FAILED + EM_CATEGORY_INVALID + EM_COMBO_VALIDATION_FAILED + EM_COMBO_MISSING_TEXT + + IM_EXPORT_VISIBLE_SUCCESS + IM_EXPORT_CATEGORY_SUCCESS + IM_IMPORT_SUCCESS + IM_EXCEL_OUT_SUCCESS + IM_STYLES_UPDATE_SUCCESS + IM_NO_CATEGORY + IM_CATEGORY_OUT + + QM_CONFIG_EDIT_CONFIRM +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 ProcessErrorMessages(expectedErrors As Scripting.Dictionary) + If Err.Number = 0 Then _ + Exit Function + + Call Unload(CSE_ProgressBar) + If Not expectedErrors.Exists(Err.Number) Then _ + Call Err.Raise(Err.Number) + + Call UserInteraction.ShowMessage(Err.Number, Err.Source) +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_EXPORT_CONFIG_FAIL: Call MsgBox(" ", vbExclamation) + Case EM_FAILED_OUTPUT_CREATION: Call MsgBox(" ", vbExclamation) + Case EM_IMPORT_FAIL: Call MsgBox(" ", vbInformation) + Case EM_CONFIG_LOAD_FAIL: Call MsgBox(" ", vbExclamation) + Case EM_CANNOT_COMBINE_STYLES: Call MsgBox(" ", vbExclamation) + Case EM_CONFIG_MISSING: Call MsgBox(" ", vbExclamation) + Case EM_ID_NOT_SELECTED: Call MsgBox(" ", vbExclamation) + Case EM_STYLE_NOT_SELECTED: Call MsgBox(" !", vbExclamation) + Case EM_CATEGORY_NOT_SELECTED: Call MsgBox(" ", vbExclamation) + Case EM_CATEGORY_INVALID: Call MsgBox(" , ", vbExclamation) + Case EM_VALIDATION_FAILED: Call MsgBox(" ", vbExclamation) + Case EM_COMBO_VALIDATION_FAILED: Call MsgBox(" ", vbExclamation) + Case EM_COMBO_MISSING_TEXT: Call MsgBox(" ", vbExclamation) + Case EM_COMBO_TAKEN: Call MsgBox(Fmt(" . : {1}", unwrapped), vbExclamation) + Case EM_CANNOT_ADD_STYLE: Call MsgBox(" ", vbExclamation) + Case EM_STYLE_TAKEN: Call MsgBox(" ", vbExclamation) + Case EM_FORMAT_TAKEN: Call MsgBox(Fmt(" . : {1}", unwrapped), vbExclamation) + Case EM_UNKNOWN_CAT_ID: Call MsgBox(" ", vbExclamation) + Case EM_CAT_NAME_TAKEN: Call MsgBox(Fmt(" : {1}", unwrapped), vbExclamation) + Case EM_STYLE_NO_FORMAT: Call MsgBox(Fmt(" : {1}", unwrapped), vbExclamation) + Case EM_INCOMPLETE_COMPOSITION: Call MsgBox(" ", vbExclamation) + Case EM_RIBBON_NOT_REACHABLE + Call MsgBox(" !" & vbNewLine & _ + ", Word ", vbExclamation) + + Case IM_EXPORT_VISIBLE_SUCCESS: Call MsgBox(" ", vbInformation) + Case IM_EXPORT_CATEGORY_SUCCESS: Call MsgBox(" ", vbInformation) + Case IM_IMPORT_SUCCESS: Call MsgBox(" ", vbInformation) + Case IM_EXCEL_OUT_SUCCESS: Call MsgBox(" ", vbInformation) + Case IM_STYLES_UPDATE_SUCCESS: Call MsgBox(" ", vbInformation) + Case IM_NO_CATEGORY: Call MsgBox(" ", vbInformation) + Case IM_CATEGORY_OUT: 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_CONFIG_EDIT_CONFIRM + answer = MsgBox("! . " & _ + vbNewLine & " ", vbYesNo + vbQuestion) + + Case Else + Call MsgBox("Invalid message code", vbCritical) + End Select + UIAskQuestion = answer = vbYes +End Function diff --git a/src/markup/z_UIRibbon.bas b/src/markup/z_UIRibbon.bas new file mode 100644 index 0000000..2c1433e --- /dev/null +++ b/src/markup/z_UIRibbon.bas @@ -0,0 +1,210 @@ +Attribute VB_Name = "z_UIRibbon" +' +Option Explicit + +Global g_RibbonWrap As API_Ribbon + +Global g_ActiveCat As Long +Global g_Configs As New Collection + +Public Function RibbonTempFile() As String + RibbonTempFile = Environ("TEMP") & "/" & TEMP_FILE_NAME & CStr(GetCurrentProcessId) & ".txt" +End Function + +Public Function ActiveCategory() As InfoCategory + If g_ActiveCat = 0 Then + Call UserInteraction.ShowMessage(EM_CATEGORY_NOT_SELECTED) + Exit Function + End If + + Set ActiveCategory = Markup.config_.GetAt(g_ActiveCat) + If ActiveCategory Is Nothing Then + Call UserInteraction.ShowMessage(EM_CATEGORY_INVALID) + Exit Function + End If +End Function + +Public Function UINextCat() + If Markup.config_.categories_.Count = 0 Then _ + Exit Function + + Dim catID As Variant + Dim nIndex&: nIndex = 0 + Dim ids() As Variant: ids = Markup.config_.categories_.Keys() + For Each catID In ids + If g_ActiveCat = catID Then + If nIndex + 1 <> ArraySize(ids) Then + g_ActiveCat = ids(nIndex + 1) + Else + g_ActiveCat = ids(0) + End If + Exit For + End If + nIndex = nIndex + 1 + Next catID + + Call UIUpdateCategories +End Function + +Public Function UIPrevCat() + Dim catID As Variant + Dim nIndex&: nIndex = 0 + Dim ids() As Variant: ids = Markup.config_.categories_.Keys() + For Each catID In ids + If g_ActiveCat = catID Then + If nIndex <> 0 Then + g_ActiveCat = ids(nIndex - 1) + Else + g_ActiveCat = ids(ArraySize(ids) - 1) + End If + Exit For + End If + nIndex = nIndex + 1 + Next catID + Call UIUpdateCategories +End Function + +Public Function UIResetCategories() + g_ActiveCat = 0 + If Markup.config_.IsLoaded Then + If Markup.config_.categories_.Count > 0 Then _ + g_ActiveCat = Markup.config_.categories_.Keys(0) + End If + Call UIUpdateCategories +End Function + +Public Function UIUpdateCategories() + Dim aRibbon As IRibbonUI: Set aRibbon = GetRibbon + If Not aRibbon Is Nothing Then _ + aRibbon.InvalidateControl ("CategoryPicker") +End Function + +Public Function UIUpdateConfigList() + Set g_Configs = GetConfigList + + Dim aRibbon As IRibbonUI: Set aRibbon = GetRibbon + If Not aRibbon Is Nothing Then _ + Call aRibbon.InvalidateControl("ConfigPicker") +End Function + +Public Sub MUC_LoadRibbon(aRibbon As IRibbonUI) + Set g_RibbonWrap = New API_Ribbon + Call g_RibbonWrap.Init(aRibbon, RibbonTempFile) + Call UIUpdateConfigList +End Sub + +Public Sub MUC_OnBtn(iControl As IRibbonControl) + Call EnsureGlobalState + Select Case iControl.ID + Case "OpenConfig": Call MU_OpenConfig + + Case "ApplyCategory": Call MU_ApplyCategory + Case "AddCategory": Call MU_AddCategory + Case "RemoveMarkup": Call MU_ClearFragment + + Case "NextCategory": Call MU_NextCategory + Case "PrevCategory": Call MU_PrevCategory + + Case "GetCategory": Call MU_DetermineCategory + Case "NextFragment": Call MU_GotoNext + Case "PreviousFragment": Call MU_GotoPrev + + Case "HideCategory": Call MU_HideText + Case "ShowCategory": Call MU_ShowText + + Case "HighlightCategory": Call MU_HighlightText + Case "UnhighlightCategory": Call MU_UnhighlightText + + Case "ExtractVisible": Call MU_ExtractVisible + Case "ExtractCategory": Call MU_ExtractCategory + Case "ExportMarkup": Call MU_ExportMarkup + Case "ImportMarkup": Call MU_ImportMarkup + Case "ExportMarkedText": Call MU_ExportMarkedText + Case "ExportHighlights": Call MU_ExportHighlights + Case "SyncStyles": Call MU_SyncStyles + Case "ViewHelp": Call MU_ViewHelp + End Select +End Sub + +Public Sub MUC_ConfigCount(control As IRibbonControl, ByRef nCount) + nCount = g_Configs.Count +End Sub + +Public Sub MUC_ConfigLabel(control As IRibbonControl, nIndex%, ByRef vLabel) + vLabel = g_Configs.Item(nIndex + 1).name_ +End Sub + +Public Sub MUC_ConfigSelected(control As IRibbonControl, ByRef val) + Call EnsureGlobalState + val = ActiveConfigIndex - 1 +End Sub + +Public Sub MUC_ConfigChange(control As IRibbonControl, sID$, nIndex As Variant) + Call EnsureGlobalState + If nIndex + 1 = ActiveConfigIndex Or nIndex = -1 Then _ + Exit Sub + + Dim sName$: sName = ActiveDocument.FullName + If MU_LoadConfigFrom(g_Configs.Item(nIndex + 1).path_) Then + Call Markup.config_.SyncStyles(ThisDocument.Application, sName) + End If +End Sub + +Sub MUC_CatsCount(control As IRibbonControl, ByRef nCount) + nCount = Markup.config_.categories_.Count +End Sub + +Public Sub MUC_CatsLabel(control As IRibbonControl, nIndex%, ByRef vLabel) + vLabel = Markup.config_.categories_.Items(nIndex).name_ +End Sub + +Public Sub MUC_CatsSelected(control As IRibbonControl, ByRef nIndex) + Call EnsureGlobalState + + nIndex = 0 + Dim catID As Variant + For Each catID In Markup.config_.categories_ + If catID = g_ActiveCat Then _ + Exit Sub + nIndex = nIndex + 1 + Next catID + nIndex = -1 +End Sub + +Public Sub MUC_CatsChange(control As IRibbonControl, ID As String, nIndex As Variant) + Call EnsureGlobalState + If nIndex = -1 Then + g_ActiveCat = vbNullString + Else + g_ActiveCat = Markup.config_.categories_.Keys(nIndex) + End If +End Sub + +' ============= +Private Function EnsureGlobalState() As Boolean + EnsureGlobalState = Not GetRibbon Is Nothing +End Function + +Private Function ActiveConfigIndex() As Integer + If Not Markup.config_.IsLoaded Then _ + Exit Function + + Dim nIndex& + For nIndex = 1 To g_Configs.Count Step 1 + If g_Configs.Item(nIndex).path_ = Markup.config_.sourcePath_ Then + ActiveConfigIndex = nIndex + Exit Function + End If + Next nIndex +End Function + +Private Function GetRibbon() As IRibbonUI + If g_RibbonWrap Is Nothing Then + Set g_RibbonWrap = New API_Ribbon + Call g_RibbonWrap.LoadFrom(RibbonTempFile) + Call UIUpdateConfigList + End If + Set GetRibbon = g_RibbonWrap.Value + If GetRibbon Is Nothing Then _ + Call UserInteraction.ShowMessage(EM_RIBBON_NOT_REACHABLE) +End Function diff --git a/src/test/s_Category.cls b/src/test/s_Category.cls new file mode 100644 index 0000000..398b3d1 --- /dev/null +++ b/src/test/s_Category.cls @@ -0,0 +1,203 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_Category" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private cat_ As InfoCategory + +Public Function Setup() + ' Mandatory setup function + Set cat_ = New InfoCategory +End Function + +Public Function Teardown() + ' Mandatory teardown function +End Function + +Public Function t_InitBasic() + On Error GoTo PROPAGATE_ERROR + + Call cat_.InitBasic(1337, "name", "info") + Call Dev_ExpectEQ(1337, cat_.id_) + Call Dev_ExpectEQ("name", cat_.name_) + Call Dev_ExpectEQ("info", cat_.info_) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_Clone() + On Error GoTo PROPAGATE_ERROR + + With cat_ + .id_ = 1337 + .name_ = "name1" + .info_ = "info1" + .style_ = "style1" + Set .composition_ = CSet(1, 2, 3) + End With + + Dim iClone As InfoCategory + Set iClone = cat_.Clone + + Call Dev_NewCase("Copy data") + Call Dev_ExpectEQ(cat_.id_, iClone.id_) + Call Dev_ExpectEQ(cat_.name_, iClone.name_) + Call Dev_ExpectEQ(cat_.info_, iClone.info_) + Call Dev_ExpectEQ(cat_.style_, iClone.style_) + Call Dev_ExpectEQ(cat_.composition_, iClone.composition_) + + With cat_ + .id_ = 1338 + .name_ = "name2" + .info_ = "info2" + .style_ = "style2" + Call .composition_.Add(4, 0) + End With + + Call Dev_NewCase("Deep copy") + Call Dev_ExpectNE(cat_.id_, iClone.id_) + Call Dev_ExpectNE(cat_.name_, iClone.name_) + Call Dev_ExpectNE(cat_.info_, iClone.info_) + Call Dev_ExpectNE(cat_.style_, iClone.style_) + Call Dev_ExpectNE(cat_.composition_, iClone.composition_) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_IsCombo() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectFalse(cat_.IsCombo, "Empty category") + + Call cat_.composition_.Add(1, 0) + Call Dev_ExpectFalse(cat_.IsCombo, "Single parent") + + Call cat_.composition_.Add(2, 0) + Call Dev_ExpectTrue(cat_.IsCombo, "Valid combo") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_IsComplete() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectFalse(cat_.IsComplete, "Empty category") + + Call Dev_NewCase("Completely defined basic") + With cat_ + .id_ = 1337 + .name_ = "name1" + .info_ = "info1" + .style_ = "style1" + End With + Call Dev_ExpectTrue(cat_.IsComplete) + + Call Dev_NewCase("Completely defined combo") + Set cat_.composition_ = CSet(1, 2, 3) + Call Dev_ExpectTrue(cat_.IsComplete) + + Call Dev_NewCase("Missing style") + cat_.style_ = "" + Call Dev_ExpectFalse(cat_.IsComplete) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ImportComposition() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectTrue(cat_.ImportComposition(""), "Empty input") + Call Dev_ExpectFalse(cat_.ImportComposition("invalid"), "Invalid id") + + Call Dev_NewCase("Single parent") + Call Dev_ExpectTrue(cat_.ImportComposition("1")) + Call Dev_ExpectEQ(1, cat_.composition_.Keys(0)) + + Call Dev_NewCase("Valid input") + Call Dev_ExpectTrue(cat_.ImportComposition("2; 3; 4")) + Call Dev_ExpectEQ(CSet(2, 3, 4), cat_.composition_) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_GetCompositionString() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ("", cat_.GetCompositionString, "Empty composition") + + Call Dev_NewCase("Single parent") + Set cat_.composition_ = CSet(1) + Call Dev_ExpectEQ("1", cat_.GetCompositionString) + + Call Dev_NewCase("Valid input") + Set cat_.composition_ = CSet(1, 2, 3) + Call Dev_ExpectEQ("1; 2; 3", cat_.GetCompositionString) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_GetFormat() + On Error GoTo PROPAGATE_ERROR + + Dim iBase As Word.Style: Set iBase = ThisDocument.Styles(wdStyleNormal) + Dim iHeader As Word.Style: Set iHeader = ThisDocument.Styles(wdStyleHeading1) + + Call Dev_NewCase("Diff with base") + Dim iEmpty As New InfoFormat + cat_.style_ = iBase.NameLocal + Dim iResult As InfoFormat: Set iResult = cat_.GetFormat(ThisDocument) + Call Dev_ExpectTrue(iResult.Compare(iEmpty) = 0) + + Call Dev_NewCase("Diff with header") + Dim iDiff As New InfoFormat: Call iDiff.InitFromWordDiff(iBase, iHeader) + cat_.style_ = iHeader.NameLocal + Set iResult = cat_.GetFormat(ThisDocument) + Call Dev_ExpectTrue(iResult.Compare(iDiff) = 0) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_IsIncludedIn() + On Error GoTo PROPAGATE_ERROR + + cat_.id_ = 1 + Call Dev_ExpectFalse(cat_.IsIncludedIn(cat_), "Self not included") + + Call Dev_NewCase("Basic included") + Dim iParent As New InfoCategory + iParent.id_ = 42 + Call Dev_ExpectFalse(iParent.IsIncludedIn(cat_), "No connection") + Set iParent.composition_ = CSet(1) + Call Dev_ExpectFalse(iParent.IsIncludedIn(cat_)) + Call Dev_ExpectTrue(cat_.IsIncludedIn(iParent)) + + Call Dev_NewCase("Complex included") + Set cat_.composition_ = CSet(2, 3) + Set iParent.composition_ = CSet(2, 3, 4) + Call Dev_ExpectFalse(iParent.IsIncludedIn(cat_)) + Call Dev_ExpectTrue(cat_.IsIncludedIn(iParent)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_Config.cls b/src/test/s_Config.cls new file mode 100644 index 0000000..2bbf9b2 --- /dev/null +++ b/src/test/s_Config.cls @@ -0,0 +1,355 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_Config" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private fso_ As Scripting.FileSystemObject +Private config_ As InfoConfig +Private wordApp_ As API_WordWrapper + +' TODO: +' Public Function SyncDocument(target As Word.Document) +' Public Function SaveAs(outPath$) As Boolean +' Public Function Save() As Boolean +' Public Function CreateStyle(targetID&, sStyleName$, iDoc As Word.Document) As Boolean + +Public Function Setup() + ' Mandatory setup function + Set config_ = New InfoConfig + Set fso_ = New Scripting.FileSystemObject + Set wordApp_ = New API_WordWrapper + Call wordApp_.SetApplication(ThisDocument.Application) + + Call ResetTestFolder +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call fso_.DeleteFolder(GetTestFolder) +End Function + +Public Function t_Load() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Valid load") + Call config_.Load(SetupTestConfig) + Call Dev_ExpectTrue(config_.IsLoaded) + Call Dev_ExpectEQ(3, config_.categories_.Count) + + Call Dev_NewCase("Missing file") + Dim iConfig As New InfoConfig + Call Dev_ExpectFalse(iConfig.IsLoaded) + Call Dev_ExpectFalse(iConfig.Load("invalid file")) + Call Dev_ExpectFalse(iConfig.IsLoaded) + Call Dev_ExpectEQ(0, iConfig.categories_.Count) + + Call Dev_NewCase("Invalid file") + Dim sFile$: sFile = GetTestFolder & "\" & "test1.docx" + Dim iWord As New API_WordWrapper: Call iWord.NewDocument + Call iWord.SaveAs(sFile) + Call iWord.ReleaseDocument + Call Dev_ExpectFalse(iConfig.Load(sFile)) + Call Dev_ExpectFalse(iConfig.IsLoaded) + Call Dev_ExpectEQ(0, iConfig.categories_.Count) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_BasicCategory() + On Error GoTo PROPAGATE_ERROR + + Dim iCat As InfoCategory + Call Dev_ExpectNothing(config_.AddBasicCategory("", ""), "Empty name") + Call Dev_ExpectNothing(config_.GetAt(1)) + + Call Dev_NewCase("Empty info") + Set iCat = config_.AddBasicCategory("test1", "") + Call Dev_AssertNotNothing(iCat) + Call Dev_ExpectEQ(1, iCat.id_) + Call Dev_ExpectEQ("test1", iCat.name_) + Call Dev_ExpectEQ("", iCat.info_) + Call Dev_ExpectEQ(iCat, config_.GetAt(1)) + Call Dev_ExpectEQ(0, config_.CountCombos) + Call Dev_ExpectEQ(1, config_.CountIncomplete) + iCat.style_ = "TStyle" + Call Dev_ExpectEQ(0, config_.CountIncomplete) + + Call Dev_NewCase("Valid basic") + Set iCat = config_.AddBasicCategory("test2", "info") + Call Dev_AssertNotNothing(iCat) + Call Dev_ExpectEQ(2, iCat.id_) + Call Dev_ExpectEQ("test2", iCat.name_) + Call Dev_ExpectEQ("info", iCat.info_) + Call Dev_ExpectEQ(0, config_.CountCombos) + Call Dev_ExpectEQ(1, config_.CountIncomplete) + + Call Dev_NewCase("Duplicate") + On Error Resume Next + Call Dev_ExpectNothing(config_.AddBasicCategory("test1", "123")) + Call Dev_ExpectError(ERR_CAT_NAME_TAKEN) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ComboCategory() + On Error GoTo PROPAGATE_ERROR + + Dim iCombo As InfoCategory + Call Dev_ExpectNothing(config_.AddCombinedCategory("", CSet()), "Empty name") + + Call Dev_NewCase("Name taken") + Dim iBase1 As InfoCategory: Set iBase1 = config_.AddBasicCategory("base1", "info1") + Dim iBase2 As InfoCategory: Set iBase2 = config_.AddBasicCategory("base2", "info2") + Dim iComp As Scripting.Dictionary: Set iComp = CSet(iBase1.id_, iBase2.id_) + On Error Resume Next + Call Dev_ExpectNothing(config_.AddCombinedCategory("base1", iComp)) + Call Dev_ExpectError(ERR_CAT_NAME_TAKEN) + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Invalid combo cat") + On Error Resume Next + Call Dev_ExpectNothing(config_.AddCombinedCategory("derived", CSet(iBase1.id_ + iBase2.id_, iBase1.id_), "info3")) + Call Dev_ExpectError(EM_UNKNOWN_CAT_ID) + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Valid combo add") + Set iCombo = config_.AddCombinedCategory("derived", iComp, "info3") + Call Dev_AssertNotNothing(iCombo) + Call Dev_ExpectEQ(3, config_.categories_.Count, "Cats count") + Call Dev_ExpectEQ(1, config_.CountCombos) + Call Dev_ExpectEQ(3, config_.CountIncomplete) + Call Dev_ExpectEQ(3, iCombo.id_) + Call Dev_ExpectEQ("derived", iCombo.name_) + Call Dev_ExpectEQ("info3", iCombo.info_) + Call Dev_ExpectEQ(iComp, iCombo.composition_) + + Call Dev_NewCase("Combo taken") + On Error Resume Next + Call Dev_ExpectNothing(config_.AddCombinedCategory("derived", iComp, "info3")) + Call Dev_ExpectError(ERR_COMBO_TAKEN) + On Error GoTo PROPAGATE_ERROR + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_EraseCategory() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty config") + Call Dev_ExpectFalse(config_.EraseCategory(1337)) + + Call Dev_NewCase("Missing id") + Dim iCat As InfoCategory: Set iCat = config_.AddBasicCategory("test", "info") + Call Dev_ExpectFalse(config_.EraseCategory(iCat.id_ + 1)) + Call Dev_ExpectEQ(1, config_.categories_.Count) + + Call Dev_NewCase("Valid erase basic") + Call Dev_ExpectTrue(config_.EraseCategory(iCat.id_)) + Call Dev_ExpectEQ(0, config_.categories_.Count) + + Call Dev_NewCase("Delete with dependencies") + Dim iParent1 As InfoCategory: Set iParent1 = config_.AddBasicCategory("test1", "info") + Dim iParent2 As InfoCategory: Set iParent2 = config_.AddBasicCategory("test2", "info") + Dim iChild As InfoCategory: Set iChild = config_.AddCombinedCategory("test3", CSet(iParent1.id_), "info") + Call Dev_ExpectTrue(config_.EraseCategory(iParent1.id_)) + Call Dev_ExpectEQ(1, config_.categories_.Count) + Call Dev_ExpectTrue(config_.Contains(iParent2.id_)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_Access() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty config") + Call Dev_ExpectFalse(config_.Contains(1337), "Contains") + Call Dev_ExpectNothing(config_.GetAt(1337), "GetAt") + Call Dev_ExpectNothing(config_.FindName("test"), "FindName") + Call Dev_ExpectNothing(config_.FindStyle("style"), "FindStyle") + Call Dev_ExpectNothing(config_.FindComposition(CSet(1, 2)), "FindComposition") + + Call Dev_NewCase("Valid access") + Dim iBase1 As InfoCategory: Set iBase1 = config_.AddBasicCategory("base1", "info1") + Dim iBase2 As InfoCategory: Set iBase2 = config_.AddBasicCategory("base2", "info2") + iBase1.style_ = "style" + Dim iComp As Scripting.Dictionary: Set iComp = CSet(iBase1.id_, iBase2.id_) + Dim iChild As InfoCategory: Set iChild = config_.AddCombinedCategory("derived", iComp, "info3") + Call Dev_ExpectTrue(config_.Contains(iBase1.id_), "Contains") + Call Dev_ExpectEQ(iBase2, config_.GetAt(iBase2.id_), "GetAt") + Call Dev_ExpectEQ(iChild, config_.FindName("derived"), "FindName") + Call Dev_ExpectEQ(iBase1, config_.FindStyle("style"), "FindStyle") + Call Dev_ExpectEQ(iChild, config_.FindComposition(iComp), "FindComposition") + + Call Dev_NewCase("Invalid access") + Call Dev_ExpectFalse(config_.Contains(1337), "Contains") + Call Dev_ExpectNothing(config_.GetAt(1337), "GetAt") + Call Dev_ExpectNothing(config_.FindName("test123"), "FindName") + Call Dev_ExpectNothing(config_.FindStyle("style123"), "FindStyle") + Call Dev_ExpectNothing(config_.FindComposition(CSet(1, 2, 3, 4)), "FindComposition") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ReduceComposition() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty config") + Call Dev_ExpectEQ(CSet(), config_.ReduceComposition(CSet)) + + Call config_.AddBasicCategory("base1") ' 1 + Call config_.AddBasicCategory("base2") ' 2 + Call config_.AddBasicCategory("base3") ' 3 + Call config_.AddCombinedCategory("derived1", CSet(1, 2)) ' 4 + Call config_.AddCombinedCategory("derived2", CSet(3, 4)) ' 5 + + Call Dev_NewCase("Invalid id") + Call Dev_ExpectNothing(config_.ReduceComposition(CSet(1, 1337))) + + Call Dev_NewCase("Valid reductions") + Call Dev_ExpectEQ(CSet(1), config_.ReduceComposition(CSet(1))) + Call Dev_ExpectEQ(CSet(1, 2), config_.ReduceComposition(CSet(4))) + Call Dev_ExpectEQ(CSet(1, 2, 3), config_.ReduceComposition(CSet(5))) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_GetChildrenOf() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty config") + Call Dev_ExpectNothing(config_.GetChildrenOf(1337)) + + Call config_.AddBasicCategory("base1") ' 1 + Call config_.AddBasicCategory("base2") ' 2 + Call config_.AddBasicCategory("base3") ' 3 + Call config_.AddCombinedCategory("derived1", CSet(1, 2)) ' 4 + Call config_.AddCombinedCategory("derived2", CSet(3, 4)) ' 5 + + Call Dev_NewCase("Valid ids") + Call Dev_ExpectEQ(CSet(), config_.GetChildrenOf(5), "Parent category") + Call Dev_ExpectEQ(CSet(5), config_.GetChildrenOf(4)) + Call Dev_ExpectEQ(CSet(4, 5), config_.GetChildrenOf(1)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_SyncStyles() + On Error GoTo PROPAGATE_ERROR + + Call config_.Load(SetupTestConfig) + Dim iDoc As Word.Document: Set iDoc = wordApp_.NewDocument() + + Call Dev_NewCase("Empty config") + Dim iConfig As New InfoConfig + On Error Resume Next + Call iConfig.SyncStyles(wordApp_.Application, iDoc.Path) + Call iConfig.SyncStyles(wordApp_.Application, iDoc.Path) + Call Dev_ExpectNoError + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Valid transfer") + Call config_.AddBasicCategory("TestIncomplete") + On Error Resume Next + Call config_.SyncStyles(wordApp_.Application, iDoc.Path) + Call Dev_ExpectNoError + On Error GoTo PROPAGATE_ERROR + Call config_.SyncStyles(wordApp_.Application, iDoc.FullName) + Call Dev_ExpectTrue(WordStyleExists(iDoc, config_.categories_(1).style_)) + + Call wordApp_.ReleaseDocument(bCloseApplication:=False, bSaveChanges:=False) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_FindFormat() + On Error GoTo PROPAGATE_ERROR + + Call config_.Load(SetupTestConfig) + Dim iDoc As Word.Document: Set iDoc = wordApp_.NewDocument(config_.sourcePath_) + Dim iFormat As New InfoFormat + + Call Dev_NewCase("Empty format") + Call Dev_ExpectNothing(config_.FindFormat(iFormat, iDoc)) + + Call Dev_NewCase("Valid find") + Call config_.AddBasicCategory("TestIncomplete") + Dim iCat As InfoCategory: Set iCat = config_.categories_(1) + Call Dev_ExpectEQ(iCat, config_.FindFormat(iCat.GetFormat(iDoc), iDoc)) + + Call wordApp_.ReleaseDocument(bCloseApplication:=False, bSaveChanges:=False) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_AssignStyle() + On Error GoTo PROPAGATE_ERROR + + Dim iDoc As Word.Document: Set iDoc = wordApp_.NewDocument() + + Call Dev_NewCase("Empty config") + Call Dev_ExpectFalse(config_.AssignStyle(1, iDoc.Styles(wdStyleNormal), iDoc)) + + Call Dev_NewCase("Valid config - errors") + Call config_.Load(SetupTestConfig) + Call config_.SyncStyles(iDoc.Application, iDoc.FullName) + Dim iStyle1 As Word.Style: Set iStyle1 = iDoc.Styles("Style1") + + Call Dev_ExpectFalse(config_.AssignStyle(1337, iStyle1, iDoc), "Invalid id") + Call Dev_ExpectFalse(config_.AssignStyle(1, iStyle1, iDoc), "Style already assigned") + + On Error Resume Next + Call Dev_ExpectFalse(config_.AssignStyle(2, iStyle1, iDoc), "Style is taken") + Call Dev_ExpectError(ERR_STYLE_TAKEN, "Style is taken") + On Error GoTo PROPAGATE_ERROR + + On Error Resume Next + Call Dev_ExpectFalse(config_.AssignStyle(1, iDoc.Styles(wdStyleNormal), iDoc), "Invalid style") + Call Dev_ExpectError(ERR_STYLE_NO_FORMAT, "Invalid style") + On Error GoTo PROPAGATE_ERROR + + Dim iStyleNew As Word.Style: Set iStyleNew = iDoc.Styles.Add("StyleNew", wdStyleTypeCharacter) + iStyleNew.Font.Italic = True + iStyleNew.Font.Bold = True + On Error Resume Next + Call Dev_ExpectFalse(config_.AssignStyle(1, iStyleNew, iDoc), "Format taken") + Call Dev_ExpectError(ERR_FORMAT_TAKEN, "Format taken") + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Valid config - assign style") + iStyleNew.Font.Underline = wdUnderlineDouble + Call Dev_ExpectTrue(config_.AssignStyle(1, iStyleNew, iDoc)) + Call Dev_ExpectTrue(config_.AssignStyle(2, iStyle1, iDoc), "Reassign old style") + + Call wordApp_.ReleaseDocument(bCloseApplication:=False, bSaveChanges:=False) + Set iDoc = wordApp_.OpenDocument(config_.sourcePath_) + Call Dev_ExpectTrue(WordStyleExists(iDoc, "StyleNew"), "Add style to config") + Call wordApp_.ReleaseDocument(bCloseApplication:=False, bSaveChanges:=False) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_DBMarkup.cls b/src/test/s_DBMarkup.cls new file mode 100644 index 0000000..05b00cd --- /dev/null +++ b/src/test/s_DBMarkup.cls @@ -0,0 +1,33 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_DBMarkup" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +' TODO: +' Public Function RemoveAll() +' Public Function ImportFromExcel(iSource As Excel.Worksheet) As Boolean +' Public Function ImportFromWord(iSource As InfoDocument) As Boolean +' Public Function RemoveSource(sourcePath$) As Long + +Public Function Setup() + ' Mandatory setup function +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call AccessData.RemoveAll +End Function + +Public Function t_Init() + On Error GoTo PROPAGATE_ERROR + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_Format.cls b/src/test/s_Format.cls new file mode 100644 index 0000000..84a26e2 --- /dev/null +++ b/src/test/s_Format.cls @@ -0,0 +1,155 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_Format" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private format_ As InfoFormat + +Public Function Setup() + ' Mandatory setup function + Set format_ = New InfoFormat +End Function + +Public Function Teardown() + ' Mandatory teardown function +End Function + +Public Function t_IsEmpty() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectTrue(format_.IsEmpty, "Empty") + + Call format_.features_.Add(T_FF_FONT_NAME, "test") + Call Dev_ExpectFalse(format_.IsEmpty, "Not empty") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_InitFromWord() + On Error GoTo PROPAGATE_ERROR + + Dim iStyle As Word.Style: Set iStyle = ThisDocument.Styles(wdStyleNormal) + Call format_.InitFromWord(iStyle) + Call Dev_ExpectFalse(format_.IsEmpty) + Call Dev_AssertEQ(TFormatFeature.[_Last] - TFormatFeature.[_First] + 1, format_.features_.Count) + Call Dev_ExpectEQ(iStyle.Font.Name, format_.features_(T_FF_FONT_NAME), "Font name") + + Call Dev_ExpectEQ(iStyle.Font.Size, format_.features_(T_FF_FONT_SIZE), "Font size") + Call Dev_ExpectEQ(iStyle.Font.Bold, format_.features_(T_FF_BOLD), "Bold") + Call Dev_ExpectEQ(iStyle.Font.Italic, format_.features_(T_FF_ITALIC), "Italic") + Call Dev_ExpectEQ(iStyle.Font.TextColor, format_.features_(T_FF_TEXT_COLOR), "Text color") + Call Dev_ExpectEQ(iStyle.Font.Shading.BackgroundPatternColor, format_.features_(T_FF_BG_COLOR), "Background color") + Call Dev_ExpectEQ(iStyle.Font.UnderlineColor, format_.features_(T_FF_UNDERLINE_COLOR), "Underline color") + Call Dev_ExpectEQ(iStyle.Font.StrikeThrough, format_.features_(T_FF_STRIKETHROUGH), "Strikethrough") + Call Dev_ExpectEQ(iStyle.Font.Underline, format_.features_(T_FF_UNDERLINE), "Underline") + Call Dev_ExpectEQ(iStyle.Font.AllCaps, format_.features_(T_FF_ALLCAPS), "All caps") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_InitFromWordDiff() + On Error GoTo PROPAGATE_ERROR + + Dim iBase As Word.Style: Set iBase = ThisDocument.Styles(wdStyleNormal) + Dim iHeader As Word.Style: Set iHeader = ThisDocument.Styles(wdStyleHeading1) + + Call Dev_NewCase("Self diff") + Call format_.InitFromWordDiff(iBase, iBase) + Call Dev_ExpectTrue(format_.IsEmpty) + Call format_.InitFromWordDiff(iHeader, iHeader) + Call Dev_ExpectTrue(format_.IsEmpty) + + Call Dev_NewCase("Valid diff") + Call format_.InitFromWordDiff(iBase, iHeader) + Call Dev_ExpectEQ(3, format_.features_.Count) + + Call Dev_ExpectEQ(iHeader.Font.Size, format_.features_(T_FF_FONT_SIZE), "Font size") + Call Dev_ExpectEQ(iHeader.Font.Bold, format_.features_(T_FF_BOLD), "Bold") + Call Dev_ExpectEQ(iHeader.Font.AllCaps, format_.features_(T_FF_ALLCAPS), "All caps") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ApplyToWordFont() + On Error GoTo PROPAGATE_ERROR + + Dim iBase As Word.Style: Set iBase = ThisDocument.Styles(wdStyleNormal) + Dim iHeader As Word.Style: Set iHeader = ThisDocument.Styles(wdStyleHeading1) + Call format_.InitFromWordDiff(iBase, iHeader) + + Call Dev_NewCase("Apply to style font") + Dim iTarget As Word.Style: Set iTarget = ThisDocument.Styles.Add("TestStyle", wdStyleTypeCharacter) + iTarget.Font.Italic = True + + Call format_.ApplyToWordFont(iTarget.Font) + Call Dev_ExpectEQ(format_.features_(T_FF_FONT_SIZE), iTarget.Font.Size, "Font size") + Call Dev_ExpectEQ(format_.features_(T_FF_BOLD), iTarget.Font.Bold, "Bold") + Call Dev_ExpectEQ(format_.features_(T_FF_ALLCAPS), iTarget.Font.AllCaps, "All caps") + Call Dev_ExpectEQ(True, iTarget.Font.Italic, "Keep undef features") + + Call iTarget.Delete + + Call Dev_NewCase("Apply to range font") + Dim rTarget As Word.Range: Set rTarget = ThisDocument.Range + Call rTarget.InsertAfter("after") + rTarget.Font.Italic = True + + Call format_.ApplyToWordFont(rTarget.Font) + Call Dev_ExpectEQ(format_.features_(T_FF_FONT_SIZE), rTarget.Font.Size, "Font size") + Call Dev_ExpectEQ(format_.features_(T_FF_BOLD), rTarget.Font.Bold, "Bold") + Call Dev_ExpectEQ(format_.features_(T_FF_ALLCAPS), rTarget.Font.AllCaps, "All caps") + Call Dev_ExpectEQ(True, rTarget.Font.Italic, "Keep undef features") + + Call rTarget.Delete + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_Merge() + On Error GoTo PROPAGATE_ERROR + + Dim f1 As New InfoFormat + Dim f2 As New InfoFormat + Call Dev_ExpectTrue(f1.IsCompatibleWith(f2), "Empty to empty") + On Error Resume Next + Call f1.MergeWith(f2) + Call Dev_ExpectNoError + On Error GoTo PROPAGATE_ERROR + + Call f1.features_.Add(T_FF_FONT_SIZE, 42) + Call Dev_ExpectTrue(f2.IsCompatibleWith(f1), "Empty to non-empty") + Call Dev_ExpectTrue(f1.IsCompatibleWith(f2), "Non-empty to empty") + + Call Dev_NewCase("Complement features") + Call f2.features_.Add(T_FF_BOLD, True) + Call Dev_ExpectTrue(f2.IsCompatibleWith(f1)) + Call Dev_ExpectTrue(f1.IsCompatibleWith(f2)) + Call f1.MergeWith(f2) + Call Dev_AssertEQ(2, f1.features_.Count) + Call Dev_ExpectEQ(42, f1.features_(T_FF_FONT_SIZE), "Font size") + Call Dev_ExpectEQ(True, f1.features_(T_FF_BOLD), "Bold") + + Call Dev_NewCase("Incompatible values") + f2.features_.Item(T_FF_BOLD) = False + Call Dev_ExpectFalse(f1.IsCompatibleWith(f2)) + Call Dev_ExpectFalse(f2.IsCompatibleWith(f1)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + diff --git a/src/test/s_MarkupAPI.cls b/src/test/s_MarkupAPI.cls new file mode 100644 index 0000000..d16e2ab --- /dev/null +++ b/src/test/s_MarkupAPI.cls @@ -0,0 +1,43 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_MarkupAPI" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +' TODO: +' Public Function InitFromCurrentDocument(target As Word.Document) As Boolean +' Public Function SyncWord(target As Word.Document) As Boolean + +' Public Function ValidateConfig(styleDoc As Word.Document) As String + +Private fso_ As Scripting.FileSystemObject +Private markup_ As MarkupAPI + +Public Function Setup() + ' Mandatory setup function + Set markup_ = New MarkupAPI + Set fso_ = New Scripting.FileSystemObject + Call ResetTestFolder + Call markup_.LoadConfig(SetupTestConfig) +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call fso_.DeleteFolder(GetTestFolder) +End Function + +Public Function t_LoadConfig() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectTrue(markup_.config_.IsLoaded) + Call Dev_ExpectEQ(3, markup_.config_.categories_.Count) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_WordDocument.cls b/src/test/s_WordDocument.cls new file mode 100644 index 0000000..e6cc9fe --- /dev/null +++ b/src/test/s_WordDocument.cls @@ -0,0 +1,341 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_WordDocument" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +' TODO: +' Public Function GetAllHighlights() As Collection ' of ItemFragment +' Public Function GetBasicFragmentsCompound() As Collection ' of ItemFragment +' Public Function GetAllFragments() As Collection ' of ItemFragment + +Private fso_ As Scripting.FileSystemObject +Private markup_ As MarkupAPI +Private word_ As API_WordWrapper +Private doc_ As InfoDocument + +Public Function Setup() + ' Mandatory setup function + Set fso_ = New Scripting.FileSystemObject + Call ResetTestFolder + Set markup_ = New MarkupAPI + Call markup_.LoadConfig(SetupTestConfig) + Set word_ = New API_WordWrapper + Call word_.SetApplication(ThisDocument.Application) + Set doc_ = New InfoDocument + Call doc_.Init(word_.NewDocument, markup_) + Call doc_.SyncStyles +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call fso_.DeleteFolder(GetTestFolder) + Call word_.ReleaseDocument +End Function + +Public Function t_ApplyCategory() + On Error GoTo PROPAGATE_ERROR + ' =================12345678901234567 + doc_.doc_.Range = "Test1 test2 test3" + + Call Dev_NewCase("Valid category") + Dim iTarget As Word.Range: Set iTarget = doc_.doc_.Range(7, 10) + Dim iCat As InfoCategory: Set iCat = markup_.config_.categories_(1) + Call Dev_ExpectTrue(doc_.ApplyCategory(iCat, iTarget)) + Call Dev_ExpectEQ(iCat.style_, iTarget.Style) + Call Dev_ExpectNE(iCat.style_, doc_.doc_.Range(6, 7).Style) + Call Dev_ExpectNE(iCat.style_, doc_.doc_.Range(10, 11).Style) + + Call Dev_NewCase("Incomplete category") + Dim iNewCat As InfoCategory: Set iNewCat = markup_.config_.AddBasicCategory("Test1233") + Call Dev_ExpectFalse(doc_.ApplyCategory(iNewCat, iTarget)) + Call Dev_ExpectEQ(iCat.style_, iTarget.Style) + + Call Dev_NewCase("Override category") + Set iCat = markup_.config_.categories_(2) + Call Dev_ExpectTrue(doc_.ApplyCategory(iCat, iTarget)) + Call Dev_ExpectEQ(iCat.style_, iTarget.Style) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ApplyFragments() + On Error GoTo PROPAGATE_ERROR + ' =================12345678901234567 + doc_.doc_.Range = "Test1 test2 test3" + + Dim iTarget1 As Word.Range: Set iTarget1 = doc_.doc_.Range(7, 10) + Dim iTarget2 As Word.Range: Set iTarget2 = doc_.doc_.Range(13, 17) + Dim iCat1 As InfoCategory: Set iCat1 = markup_.config_.categories_(1) + Dim iCat2 As InfoCategory: Set iCat2 = markup_.config_.categories_(2) + + Call Dev_NewCase("Empty input") + Dim iFragments As New Collection + On Error Resume Next + Call Dev_ExpectTrue(doc_.ApplyFragments(iFragments)) + Call Dev_ExpectNoError + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Valid input") + Dim iFrag As New ItemFragment + Call iFrag.Init(iCat1.id_, iTarget1.Start, iTarget1.End) + Call iFragments.Add(iFrag.Clone) + Call iFrag.Init(iCat2.id_, iTarget2.Start, iTarget2.End) + Call iFragments.Add(iFrag.Clone) + Call Dev_ExpectTrue(doc_.ApplyFragments(iFragments)) + Call Dev_ExpectEQ(iCat1.style_, iTarget1.Style) + Call Dev_ExpectEQ(iCat2.style_, iTarget2.Style) + + Call Dev_NewCase("Invalid category") + iFragments.Item(1).id_ = 1337 + Call Dev_ExpectFalse(doc_.ApplyFragments(iFragments)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_AddCategory() + On Error GoTo PROPAGATE_ERROR + ' =================12345678901234567 + doc_.doc_.Range = "Test1 test2 test3" + + Call Dev_NewCase("Add to empty") + Dim iTarget As Word.Range: Set iTarget = doc_.doc_.Range(7, 10) + Dim iCat1 As InfoCategory: Set iCat1 = markup_.config_.categories_(1) + Call Dev_ExpectTrue(doc_.AddCategory(iCat1, iTarget)) + Call Dev_ExpectEQ(iCat1.style_, iTarget.Style) + Call Dev_ExpectNE(iCat1.style_, doc_.doc_.Range(6, 7).Style) + Call Dev_ExpectNE(iCat1.style_, doc_.doc_.Range(10, 11).Style) + + Call Dev_NewCase("Incomplete category") + Dim iNewCat As InfoCategory: Set iNewCat = markup_.config_.AddBasicCategory("Test1233") + Call Dev_ExpectFalse(doc_.ApplyCategory(iNewCat, iTarget)) + Call Dev_ExpectEQ(iCat1.style_, iTarget.Style) + + Call Dev_NewCase("Add to same") + Call Dev_ExpectTrue(doc_.AddCategory(iCat1, iTarget)) + Call Dev_ExpectEQ(iCat1.style_, iTarget.Style) + + Call Dev_NewCase("Add with new merge") + Dim iCat2 As InfoCategory: Set iCat2 = markup_.config_.categories_(2) + Dim nCount&: nCount = markup_.config_.categories_.Count + Call Dev_ExpectFalse(doc_.AddCategory(iCat2, iTarget)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_SetCategoryVisible() + On Error GoTo PROPAGATE_ERROR + ' =================12345678901234567 + doc_.doc_.Range = "Test1 test2 test3" + Dim iTarget As Word.Range: Set iTarget = doc_.doc_.Range(7, 10) + Dim iCat As InfoCategory: Set iCat = markup_.config_.categories_(1) + + Call Dev_NewCase("No formatting") + On Error Resume Next + Call doc_.SetCategoryVisible(1337, bShow:=False) + Call Dev_ExpectNoError("Invalid ID") + On Error Resume Next + Call doc_.SetCategoryVisible(1, bShow:=False) + Call Dev_ExpectNoError("No formatting") + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Valid visibility") + Call Dev_AssertTrue(doc_.ApplyCategory(iCat, iTarget)) + Call doc_.SetCategoryVisible(iCat.id_, bShow:=True) + Call Dev_ExpectFalse(iTarget.Font.Hidden, "Show visible") + Call doc_.SetCategoryVisible(iCat.id_, bShow:=False) + Call Dev_ExpectTrue(iTarget.Font.Hidden, "Hide visible") + Call doc_.SetCategoryVisible(iCat.id_, bShow:=False) + Call Dev_ExpectTrue(iTarget.Font.Hidden, "Hide hiden") + Call doc_.SetCategoryVisible(iCat.id_, bShow:=True) + Call Dev_ExpectFalse(iTarget.Font.Hidden, "Show visible") + + Call Dev_NewCase("Multiple targets") + Dim iTarget2 As Word.Range: Set iTarget2 = doc_.doc_.Range(1, 5) + Call Dev_AssertTrue(doc_.ApplyCategory(iCat, iTarget2)) + Call doc_.SetCategoryVisible(iCat.id_, bShow:=False) + Call Dev_ExpectTrue(iTarget.Font.Hidden) + Call Dev_ExpectTrue(iTarget2.Font.Hidden) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_SetCategoryHighlight() + On Error GoTo PROPAGATE_ERROR + ' =================12345678901234567 + doc_.doc_.Range = "Test1 test2 test3" + Dim iTarget As Word.Range: Set iTarget = doc_.doc_.Range(7, 10) + Dim iCat As InfoCategory: Set iCat = markup_.config_.categories_(1) + + Call Dev_NewCase("No formatting") + On Error Resume Next + Call doc_.SetCategoryHighlight(1337, bHighlight:=False) + Call Dev_ExpectNoError("Invalid ID") + On Error Resume Next + Call doc_.SetCategoryHighlight(1, bHighlight:=False) + Call Dev_ExpectNoError("No formatting") + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Valid visibility") + Call Dev_AssertTrue(doc_.ApplyCategory(iCat, iTarget)) + Call doc_.SetCategoryHighlight(iCat.id_, bHighlight:=False) + Call Dev_ExpectEQ(wdNoHighlight, iTarget.HighlightColorIndex, "Unhighlight plain") + Call doc_.SetCategoryHighlight(iCat.id_, bHighlight:=True) + Call Dev_ExpectEQ(wdYellow, iTarget.HighlightColorIndex, "Highlight plain") + Call doc_.SetCategoryHighlight(iCat.id_, bHighlight:=True) + Call Dev_ExpectEQ(wdYellow, iTarget.HighlightColorIndex, "Highlight highlighted") + Call doc_.SetCategoryHighlight(iCat.id_, bHighlight:=False) + Call Dev_ExpectEQ(wdNoHighlight, iTarget.HighlightColorIndex, "Unhighlight highlighted") + + Call Dev_NewCase("Multiple targets") + Dim iTarget2 As Word.Range: Set iTarget2 = doc_.doc_.Range(1, 5) + Call Dev_AssertTrue(doc_.ApplyCategory(iCat, iTarget2)) + Call doc_.SetCategoryHighlight(iCat.id_, bHighlight:=True) + Call Dev_ExpectEQ(wdYellow, iTarget.HighlightColorIndex) + Call Dev_ExpectEQ(wdYellow, iTarget.HighlightColorIndex) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_IteratorFormat() + On Error GoTo PROPAGATE_ERROR + ' =================12345678901234567 + doc_.doc_.Range = "Test1 test2 test3" + Dim iTarget As Word.Range: Set iTarget = doc_.doc_.Range(7, 10) + Dim iCat As InfoCategory: Set iCat = markup_.config_.categories_(1) + Dim iter As IteratorFormat + + Call Dev_NewCase("Invalid ID") + On Error Resume Next + Call Dev_ExpectNothing(doc_.GetFormatIterator(1337)) + Call Dev_ExpectNoError + + Call Dev_NewCase("Past end") + On Error Resume Next + Call Dev_ExpectNothing(doc_.GetFormatIterator(iCat.id_, doc_.doc_.Range.End + 1)) + Call Dev_ExpectNoError + + Call Dev_NewCase("No formatting") + On Error Resume Next + Set iter = doc_.GetFormatIterator(iCat.id_) + Call Dev_ExpectNotNothing(iter) + Call Dev_ExpectNoError + Call Dev_ExpectEQ(doc_.doc_.Range(0, 0), iter.Range) + Call Dev_ExpectNothing(iter.MoveNext) + Call Dev_ExpectNothing(iter.MovePrev) + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Valid category iter") + Call doc_.ApplyCategory(iCat, iTarget) + Set iter = doc_.GetFormatIterator(iCat.id_) + Call Dev_ExpectNotNothing(iter) + Call Dev_ExpectEQ(doc_.doc_.Range(0, 0), iter.Range) + Call Dev_ExpectEQ(iTarget, iter.MoveNext(), "Move next") + Call Dev_ExpectEQ(iTarget, iter.Range) + Call Dev_ExpectNothing(iter.MoveNext(), "Move next") + Call Dev_ExpectEQ(iTarget, iter.Range) + Call Dev_ExpectNothing(iter.MovePrev(), "Move prev") + Call Dev_ExpectEQ(iTarget, iter.Range) + + Call Dev_NewCase("Valid format") + Dim iTarget2 As Word.Range: Set iTarget2 = doc_.doc_.Range(13, 17) + Call iCat.GetFormat(doc_.doc_).ApplyToWordFont(iTarget2.Font) + Call Dev_ExpectEQ(iTarget2, iter.MoveNext(), "Move next") + Call Dev_ExpectEQ(iTarget, iter.MovePrev(), "Move prev") + + Call Dev_NewCase("Mixed format") + Dim iTarget3 As Word.Range: Set iTarget3 = doc_.doc_.Range(3, iTarget.Start) + Call iCat.GetFormat(doc_.doc_).ApplyToWordFont(iTarget3.Font) + Set iter = doc_.GetFormatIterator(iCat.id_) + Call Dev_ExpectEQ(doc_.doc_.Range(iTarget3.Start, iTarget.End), iter.MoveNext()) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_IteratorStyle() + On Error GoTo PROPAGATE_ERROR + ' =================12345678901234567 + doc_.doc_.Range = "Test1 test2 test3" + Dim iTarget As Word.Range: Set iTarget = doc_.doc_.Range(7, 10) + Dim iCat As InfoCategory: Set iCat = markup_.config_.categories_(1) + Dim iter As IteratorStyle + + Call Dev_NewCase("Invalid ID") + On Error Resume Next + Call Dev_ExpectNothing(doc_.GetStylesIterator(1337)) + Call Dev_ExpectNothing(doc_.GetPreciseIterator(1337)) + Call Dev_ExpectNoError + + Call Dev_NewCase("Past end") + On Error Resume Next + Call Dev_ExpectNothing(doc_.GetStylesIterator(iCat.id_, doc_.doc_.Range.End + 1)) + Call Dev_ExpectNothing(doc_.GetPreciseIterator(iCat.id_, doc_.doc_.Range.End + 1)) + Call Dev_ExpectNoError + + Call Dev_NewCase("No formatting") + On Error Resume Next + Set iter = doc_.GetStylesIterator(iCat.id_) + Call Dev_ExpectNotNothing(iter) + Call Dev_ExpectNoError + Call Dev_ExpectEQ(doc_.doc_.Range(0, 0), iter.Range) + Call Dev_ExpectNothing(iter.MoveNext) + Call Dev_ExpectNothing(iter.MovePrev) + + On Error Resume Next + Set iter = doc_.GetPreciseIterator(iCat.id_) + Call Dev_ExpectNotNothing(iter) + Call Dev_ExpectNoError + Call Dev_ExpectEQ(doc_.doc_.Range(0, 0), iter.Range) + Call Dev_ExpectNothing(iter.MoveNext) + Call Dev_ExpectNothing(iter.MovePrev) + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Valid category iter") + Call doc_.ApplyCategory(iCat, iTarget) + Set iter = doc_.GetPreciseIterator(iCat.id_) + Call Dev_ExpectNotNothing(iter) + Call Dev_ExpectEQ(doc_.doc_.Range(0, 0), iter.Range) + Call Dev_ExpectEQ(iTarget, iter.MoveNext(), "Move next") + Call Dev_ExpectEQ(iTarget, iter.Range) + Call Dev_ExpectNothing(iter.MoveNext(), "Move next") + Call Dev_ExpectEQ(iTarget, iter.Range) + Call Dev_ExpectNothing(iter.MovePrev(), "Move prev") + Call Dev_ExpectEQ(iTarget, iter.Range) + + Call Dev_NewCase("Valid format") + Dim iTarget2 As Word.Range: Set iTarget2 = doc_.doc_.Range(13, 17) + Call iCat.GetFormat(doc_.doc_).ApplyToWordFont(iTarget2.Font) + Call Dev_ExpectNothing(iter.MoveNext(), "Move next") + Call Dev_ExpectNothing(iter.MovePrev(), "Move prev") + + Call Dev_NewCase("Multiple styles") + Dim iTarget3 As Word.Range: Set iTarget3 = doc_.doc_.Range(3, iTarget.Start) + Dim iTarget4 As Word.Range: Set iTarget4 = doc_.doc_.Range(iTarget.End, 12) + Dim iCat2 As InfoCategory: Set iCat2 = markup_.config_.GetAt(2) + Call doc_.ApplyCategory(iCat, iTarget3) + Call doc_.ApplyCategory(iCat2, iTarget4) + Set iter = New IteratorStyle: Call iter.Init(doc_.doc_, CColl(iCat.style_, iCat2.style_)) + Call Dev_ExpectEQ(doc_.doc_.Range(iTarget3.Start, iTarget4.End), iter.MoveNext()) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + diff --git a/src/utils/interview/Declarations.bas b/src/utils/interview/Declarations.bas new file mode 100644 index 0000000..20f44d6 --- /dev/null +++ b/src/utils/interview/Declarations.bas @@ -0,0 +1,25 @@ +Attribute VB_Name = "Declarations" +Option Explicit +Option Private Module + +Public Enum ItemStructure + IS_ID = 1 + IS_PROBLEM = 2 + IS_CONSEQUENCE = 3 + IS_NOVELTY = 4 + IS_EFFECT = 5 +End Enum + +Public Enum InputStruct + INPS_ID = 1 + INPS_START = 2 + INPS_FINISH = 3 + INPS_TYPE = 4 + INPS_TEXT = 5 + INPS_COMMENT = 6 +End Enum + +Public Const DATA_DEFAULT_ID = "N/A" +Public Const TYPE_NO_TYPE = 0 + +Public Const SHT_DATA = "" diff --git a/src/utils/interview/Main.bas b/src/utils/interview/Main.bas new file mode 100644 index 0000000..46a51eb --- /dev/null +++ b/src/utils/interview/Main.bas @@ -0,0 +1,27 @@ +Attribute VB_Name = "Main" +Option Explicit + +Public Sub RunImport() + Dim sFileName$: sFileName = UserInteraction.PromptFileFilter( _ + ThisWorkbook.Path, _ + sDescription:=" Excel", _ + sFilter:="*.xlsx;*.xls;*.xlsm") + If sFileName = vbNullString Then _ + Exit Sub + + Dim xlApp As New API_XLWrapper + If xlApp.OpenDocument(sFileName, bReadOnly:=True) Is Nothing Then + Call UserInteraction.ShowMessage(EM_IMPORT_FAILED) + Exit Sub + End If + + Dim uiWrap As New API_XLWrapper: Call uiWrap.SetDocument(ThisWorkbook) + Call uiWrap.PauseUI + + Call ImportFrom(xlApp.Document) + Call xlApp.ReleaseDocument + + Call uiWrap.ResumeUI + + Call UserInteraction.ShowMessage(IM_IMPORT_OK) +End Sub diff --git a/src/utils/interview/MainImpl.bas b/src/utils/interview/MainImpl.bas new file mode 100644 index 0000000..61a5e95 --- /dev/null +++ b/src/utils/interview/MainImpl.bas @@ -0,0 +1,70 @@ +Attribute VB_Name = "MainImpl" +Option Explicit + +Public Function ImportFrom(wbSource As Excel.Workbook) + Dim dest As Excel.Worksheet: Set dest = ThisWorkbook.Sheets(SHT_DATA) + Dim src As Excel.Worksheet: Set src = wbSource.Sheets(1) + + Dim rowOut&: rowOut = 2 + Do While dest.Cells(rowOut, 1) <> vbNullString + rowOut = rowOut + 1 + Loop + + Dim idRows As New Collection + Dim rowIn&: rowIn = 2 + Dim lastType&: lastType = TYPE_NO_TYPE + Dim lastEnd&: lastEnd = 0 + Dim lastID$: lastID = vbNullString + Dim targetRow& + Do While src.Cells(rowIn, 1) <> vbNullString + Dim sID$: sID = src.Cells(rowIn, INPS_COMMENT) + Dim nColumn&: nColumn = TypeToStruct(src.Cells(rowIn, INPS_TYPE)) + + If sID = vbNullString Then + sID = DATA_DEFAULT_ID + targetRow = rowOut + rowOut = rowOut + 1 + ElseIf InCollection(sID, idRows) Then + targetRow = idRows.Item(sID) + Else + Call idRows.Add(rowOut, sID) + targetRow = rowOut + rowOut = rowOut + 1 + End If + + dest.Cells(targetRow, IS_ID) = sID + If sID = lastID And src.Cells(rowIn, INPS_TYPE) = lastType And src.Cells(rowIn, INPS_START) = lastEnd Then + Call ConcatinateCell(dest.Cells(targetRow, nColumn), src.Cells(rowIn, INPS_TEXT).Text) + Else + Call AddToCell(dest.Cells(targetRow, nColumn), src.Cells(rowIn, INPS_TEXT).Text) + End If + + lastType = src.Cells(rowIn, INPS_TYPE) + lastID = sID + lastEnd = src.Cells(rowIn, INPS_FINISH) + rowIn = rowIn + 1 + Loop +End Function + +' ========== +Private Function TypeToStruct(styleType&) As ItemStructure + TypeToStruct = styleType + 1 +End Function + +Private Function AddToCell(target As Excel.Range, sData$) + Dim newTxt$: newTxt = sData + If target.Text <> vbNullString Then + newTxt = target.Text & Chr(10) & "------" & Chr(10) & sData + End If + target = newTxt + target.WrapText = False +End Function + +Private Function ConcatinateCell(target As Excel.Range, sData$) + Dim newTxt$: newTxt = sData + If target.Text <> vbNullString Then + newTxt = target.Text & Chr(10) & newTxt + End If + target = newTxt + target.WrapText = False +End Function diff --git a/src/utils/interview/z_UIMessages.bas b/src/utils/interview/z_UIMessages.bas new file mode 100644 index 0000000..7556411 --- /dev/null +++ b/src/utils/interview/z_UIMessages.bas @@ -0,0 +1,57 @@ +Attribute VB_Name = "z_UIMessages" +' Messaging module +Option Private Module +Option Explicit + +Public Enum MsgCode + MSG_OK = 0 + + EM_IMPORT_FAILED + + IM_IMPORT_OK + +' QM_CLEAR_BEFORE_READD +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_IMPORT_FAILED + Call MsgBox(" ", vbExclamation) + + Case IM_IMPORT_OK + Call MsgBox(" ", vbInformation) + + Case Else + Call MsgBox("Invalid message code", 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_CLEAR_BEFORE_READD + ' answer = MsgBox(" . ?", vbYesNo + vbQuestion) + + Case Else + Call MsgBox("Invalid message code", vbCritical) + End Select + UIAskQuestion = answer = vbYes +End Function diff --git a/test/TestConfig.docx b/test/TestConfig.docx new file mode 100644 index 0000000..07916bb Binary files /dev/null and b/test/TestConfig.docx differ diff --git a/ui/aggregator/.rels b/ui/aggregator/.rels new file mode 100644 index 0000000..3107a8e --- /dev/null +++ b/ui/aggregator/.rels @@ -0,0 +1,2 @@ + + \ No newline at end of file diff --git a/ui/aggregator/customUI.xml b/ui/aggregator/customUI.xml new file mode 100644 index 0000000..f651a7e --- /dev/null +++ b/ui/aggregator/customUI.xml @@ -0,0 +1,31 @@ + + + + + + +