commit c5221f523b7dea79b5fd89cd77bad687d6779784 Author: IRBorisov <8611739+IRBorisov@users.noreply.github.com> Date: Fri Jun 7 20:11:38 2024 +0300 Initial commit diff --git a/VBAMake.txt b/VBAMake.txt new file mode 100644 index 0000000..3fc5490 --- /dev/null +++ b/VBAMake.txt @@ -0,0 +1,60 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact_home, source_home + +id = Concept-NPA +name = Концепт-НПА +description = Технология удержания НПА предметной области +artifact_home = Концепт-НПА +source_home = Concept-NPA +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\addinManifest.txt +build script\databaseManifest.txt +build script\viewManifest.txt +build script\visualManifest.txt + +copy skeleton\Графовое представление.gephi +copy distr\!!Листовка.docx +copy distr\!Руководство пользователя.docx +copy distr\Install.bat -> Надстройка\Install.bat +copy distr\Uninstall.bat -> Надстройка\Uninstall.bat +copy distr\Примеры иллюстраций +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 Надстройка\_Concept-NPA.dotm -> Надстройка\_Concept-NPA.dotm +install !Реестр НПА.xlsm +install НПА UI.xltm +install Схема Реестра.vstm + +install !!Листовка.docx +install !Руководство пользователя.docx +install Графовое представление.gephi +install Надстройка\Install.bat -> Надстройка\Install.bat +install Надстройка\Uninstall.bat -> Надстройка\Uninstall.bat +install Примеры иллюстраций +install Инструкции + +install Надстройка\_Concept-NPA.dotm -> \\fs1.concept.ru\Exchange\ConceptDistr\data\Add-ins\Word\_Concept-NPA.dotm +install !Реестр НПА.xlsm -> \\fs1.concept.ru\Exchange\ConceptDistr\data\!Реестр НПА.xlsm + +add_template НПА UI.xltm -> 60 НПА UI.xltm +add_template Схема Реестра.vstm -> 21 Схема Реестра НПА.vstm \ No newline at end of file diff --git a/VERSION b/VERSION new file mode 100644 index 0000000..f0bb29e --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +1.3.0 diff --git a/distr/!!Листовка.docx b/distr/!!Листовка.docx new file mode 100644 index 0000000..e80dd08 Binary files /dev/null and b/distr/!!Листовка.docx differ diff --git a/distr/!Руководство пользователя.docx b/distr/!Руководство пользователя.docx new file mode 100644 index 0000000..359b495 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..bbc2b22 --- /dev/null +++ b/distr/Install.bat @@ -0,0 +1,3 @@ +@echo off + +copy "_Concept-NPA.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..aa04681 --- /dev/null +++ b/distr/Uninstall.bat @@ -0,0 +1,3 @@ +@echo off + +del "%APPDATA%\Microsoft\Word\STARTUP\_Concept-NPA.dotm" \ No newline at end of file diff --git a/distr/Инструкции/2020 Перечень операций gephi для группировки вершин.docx b/distr/Инструкции/2020 Перечень операций gephi для группировки вершин.docx new file mode 100644 index 0000000..6445723 Binary files /dev/null and b/distr/Инструкции/2020 Перечень операций gephi для группировки вершин.docx differ diff --git a/distr/Примеры иллюстраций/input.xlsx b/distr/Примеры иллюстраций/input.xlsx new file mode 100644 index 0000000..aeb32c5 Binary files /dev/null and b/distr/Примеры иллюстраций/input.xlsx differ diff --git a/distr/Примеры иллюстраций/Графовое представление.pdf b/distr/Примеры иллюстраций/Графовое представление.pdf new file mode 100644 index 0000000..ec5c61a Binary files /dev/null and b/distr/Примеры иллюстраций/Графовое представление.pdf differ diff --git a/distr/Примеры иллюстраций/Иерархическое представление.pdf b/distr/Примеры иллюстраций/Иерархическое представление.pdf new file mode 100644 index 0000000..8e66faa Binary files /dev/null and b/distr/Примеры иллюстраций/Иерархическое представление.pdf differ diff --git a/distr/Примеры иллюстраций/Связи.gephi b/distr/Примеры иллюстраций/Связи.gephi new file mode 100644 index 0000000..cbfe3c1 Binary files /dev/null and b/distr/Примеры иллюстраций/Связи.gephi differ diff --git a/script/addinManifest.txt b/script/addinManifest.txt new file mode 100644 index 0000000..23c8388 --- /dev/null +++ b/script/addinManifest.txt @@ -0,0 +1,120 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact + +name = _Concept-NPA.dotm +artifact = Надстройка\_Concept-NPA.dotm + +%% +# === Imports Section === +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SharedHome path + +dev + DevTester.bas + DevTesterUI.bas + API_MockInteraction.cls + +api + ex_WinAPI.bas + API_Path.cls + API_WordWrapper.cls + API_XLWrapper.cls + API_UserInteraction.cls + +parsers + z_ParserRegex.bas + PC_InfoNPA.cls + ParserDate.cls + ParserNPA.cls + +utility + ex_VBA.bas + ex_Hash.bas + ex_Collection.bas + ex_Regex.bas + ex_DataPreparation.bas + +word + ex_Word.bas + +ui + CSE_ProgressBar.frm + +%% +# === Source Code Section == +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SourceHome path + +src + common + DocumentProcessor.bas + DatabaseModel.bas + DatabaseImpl.bas + + ItemLink.cls + ItemHyperlink.cls + ItemLaw.cls + ItemCachedLaw.cls + ItemDocumentModification.cls + + IteratorLaw.cls + IteratorLinkAll.cls + IteratorLinkCached.cls + IteratorLinkLaw.cls + + InfoDatabase.cls + InfoDocument.cls + + addin + DummyDocDlg.frm + LinkTypeDlg.frm + NewDocumentDlg.frm + NewLinkDlg.frm + LinkToNewDocDlg.frm + + DevHelper.bas + Declarations.bas + Main.bas + MainImpl.bas + z_UIRibbon.bas + z_UIMessages.bas + + ItemLinkModification.cls + ItemDocumentProperties.cls + InfoWordDatabase.cls + + test + s_DocumentProcessor.cls + s_ItemHyperlink.cls + s_InfoDocument.cls + s_InfoWordDatabase.cls + s_AddinAPI.cls + s_WordDataAccess.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 + +addin\.rels -> _rels\.rels +addin\customUI.xml -> customUI\customUI.xml +addin\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 : VBScript_RegExp_55 +global : Scripting +global : Shell32 +global : MSScriptControl +global : MSForms +global : Excel \ No newline at end of file diff --git a/script/databaseManifest.txt b/script/databaseManifest.txt new file mode 100644 index 0000000..dfbe59b --- /dev/null +++ b/script/databaseManifest.txt @@ -0,0 +1,117 @@ +# == 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_Path.cls + API_WordWrapper.cls + API_XLWrapper.cls + API_UserInteraction.cls + +parsers + z_ParserRegex.bas + PC_InfoNPA.cls + ParserDate.cls + ParserNPA.cls + +utility + ex_VBA.bas + ex_Hash.bas + ex_Version.bas + + API_DistrManifest.cls + API_JSON.cls + ex_Collection.bas + ex_Regex.bas + ex_DataPreparation.bas + +ui + CSE_ProgressBar.frm + +word + ex_Word.bas + +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 + DocumentProcessor.bas + DatabaseModel.bas + DatabaseImpl.bas + + ActiveStateExporter.cls + + ItemLink.cls + ItemHyperlink.cls + ItemLaw.cls + ItemCachedLaw.cls + ItemDocumentModification.cls + + IteratorLaw.cls + IteratorLinkAll.cls + IteratorLinkCached.cls + IteratorLinkLaw.cls + + InfoDatabase.cls + InfoDocument.cls + + database + MergeLawsDlg.frm + + ItemMerge.cls + + DataAccess.bas + DevHelper.bas + Declarations.bas + Main.bas + MainImpl.bas + ManualSubs.bas + z_UIRibbon.bas + z_UIMessages.bas + + test + s_ActiveStateExporter.cls + s_Database.cls + s_DatabaseManager.cls + s_IteratorLaw.cls + s_IteratorLinkAll.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 + +database\.rels -> _rels\.rels +database\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 : VBScript_RegExp_55 +global : Scripting +global : MSForms +global : Word +global : Shell32 \ No newline at end of file diff --git a/script/viewManifest.txt b/script/viewManifest.txt new file mode 100644 index 0000000..b2b6318 --- /dev/null +++ b/script/viewManifest.txt @@ -0,0 +1,120 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact + +name = НПА UI.xltm +artifact = НПА UI.xltm + +%% +# === 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_Path.cls + API_WordWrapper.cls + API_XLWrapper.cls + API_UserInteraction.cls + +utility + ex_VBA.bas + ex_Hash.bas + ex_Collection.bas + ex_DataPreparation.bas + ex_Version.bas + + API_DistrManifest.cls + API_JSON.cls + CDS_Graph.cls + CDS_Node.cls + CDS_Edge.cls + +parsers + z_ParserRegex.bas + PC_InfoNPA.cls + ParserDate.cls + ParserNPA.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 + DocumentProcessor.bas + DatabaseModel.bas + DatabaseImpl.bas + + ActiveStateExporter.cls + + ItemLink.cls + ItemHyperlink.cls + ItemLaw.cls + ItemCachedLaw.cls + ItemDocumentModification.cls + + IteratorLaw.cls + IteratorLinkAll.cls + IteratorLinkCached.cls + IteratorLinkLaw.cls + + InfoDatabase.cls + InfoDocument.cls + + view + DataAccess.bas + Declarations.bas + DevHelper.bas + Main.bas + MainImpl.bas + z_UIRibbon.bas + z_UIMessages.bas + + UIState.cls + QFilterLaws.cls + QFilterLinkType.cls + QFilterLinkComplex.cls + QFilterLinkRow.cls + QueryMaster.cls + DataImporter.cls + + test + s_DatabaseView.cls + s_QueryMaster.cls + s_DataImporter.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 + +view\.rels -> _rels\.rels +view\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 : VBScript_RegExp_55 +global : Scripting +global : MSForms +global : Word +global : Shell32 \ No newline at end of file diff --git a/script/visualManifest.txt b/script/visualManifest.txt new file mode 100644 index 0000000..f081ddc --- /dev/null +++ b/script/visualManifest.txt @@ -0,0 +1,93 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact + +name = Схема Реестра.vstm +artifact = Схема Реестра.vstm + +%% +# === 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_VsoWrapper.cls + API_WordWrapper.cls + API_XLWrapper.cls + API_UserInteraction.cls + +utility + ex_VBA.bas + ex_Collection.bas + ex_Version.bas + + API_DistrManifest.cls + API_JSON.cls + CDS_Factorizator.cls + CDS_Graph.cls + CDS_Node.cls + CDS_Edge.cls + +ui + CSE_ProgressBar.frm + +visio + z_VsoUtilities.bas + z_CCVsoExtension.bas + z_VsoGraph.bas + API_UndoWrapper.cls + +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 + DatabaseModel.bas + + visual + ImportDataDlg.frm + + Declarations.bas + DevHelper.bas + Main.bas + MainImpl.bas + z_UIRibbon.bas + z_UIMessages.bas + + ItemImportOptions.cls + ImportManager.cls + LayoutManager.cls + + test + s_LayoutManager.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 + +visual\.rels -> _rels\.rels +visual\customUI1.xml -> visio\customUI\customUI1.xml + +%% +# === References Section === +# List dependencies in one of the formats +# global : GLOBAL_NAME +# guid : {REGISTERED_GUID} +# file : PATH_TO_LIBRARY + +global : Shell32 +global : MSForms +global : Scripting +global : Word +global : Excel \ No newline at end of file diff --git a/skeleton/!Реестр НПА.xlsm b/skeleton/!Реестр НПА.xlsm new file mode 100644 index 0000000..67db808 Binary files /dev/null and b/skeleton/!Реестр НПА.xlsm differ diff --git a/skeleton/_Concept-NPA.dotm b/skeleton/_Concept-NPA.dotm new file mode 100644 index 0000000..e3c59ac Binary files /dev/null and b/skeleton/_Concept-NPA.dotm differ diff --git a/skeleton/Графовое представление.gephi b/skeleton/Графовое представление.gephi new file mode 100644 index 0000000..6223fd7 Binary files /dev/null and b/skeleton/Графовое представление.gephi differ diff --git a/skeleton/НПА UI.xltm b/skeleton/НПА UI.xltm new file mode 100644 index 0000000..900598d Binary files /dev/null and b/skeleton/НПА UI.xltm differ diff --git a/skeleton/Схема Реестра.vstm b/skeleton/Схема Реестра.vstm new file mode 100644 index 0000000..116c557 Binary files /dev/null and b/skeleton/Схема Реестра.vstm differ diff --git a/src/addin/Declarations.bas b/src/addin/Declarations.bas new file mode 100644 index 0000000..74d07ad --- /dev/null +++ b/src/addin/Declarations.bas @@ -0,0 +1,46 @@ +Attribute VB_Name = "Declarations" +' ========== Specific declarations for Word module ========== +Option Explicit + +Public Const HELP_WORD_BOOKMARK = "HT03_WORD" +Public Const HELP_FILE_PATH = "\\fs1.concept.ru\Projects\10 \01 \-\! .docx" + +Public Function AccessDatabase() As InfoDatabase + Static s_AccessDatabase As InfoDatabase + + On Error GoTo CREATE_NEW + Set AccessDatabase = s_AccessDatabase.Validate + Exit Function + +CREATE_NEW: + Set s_AccessDatabase = New InfoDatabase + Dim dbDoc As Excel.Workbook: Set dbDoc = GetDatabaseDocument(Word.ActiveDocument) + If Not dbDoc Is Nothing Then _ + Call s_AccessDatabase.Init(dbDoc, GetDocumentsLocation(dbDoc)) + + Set AccessDatabase = s_AccessDatabase +End Function + +Public Function AccessWordDatabase() As InfoWordDatabase + Static s_Database As InfoWordDatabase + + On Error GoTo CREATE_NEW + Call s_Database.source_.Validate + Set AccessWordDatabase = s_Database + Exit Function + +CREATE_NEW: + Set s_Database = New InfoWordDatabase + Call s_Database.Init(AccessDatabase) + Set AccessWordDatabase = s_Database +End Function + +Public Function GetDatabaseDocument(iReference As Word.Document) As Excel.Workbook + Dim fso As New Scripting.FileSystemObject + Dim sFile$: sFile = iReference.Path & "\" & HT03_DBNAME + If Not fso.FileExists(sFile) Then _ + sFile = fso.GetParentFolderName(iReference.Path) & "\" & HT03_DBNAME + + Dim wrapper As New API_XLWrapper + Set GetDatabaseDocument = wrapper.OpenDocument(sFile, bIgnoreFolder:=True) +End Function diff --git a/src/addin/DevHelper.bas b/src/addin/DevHelper.bas new file mode 100644 index 0000000..972808e --- /dev/null +++ b/src/addin/DevHelper.bas @@ -0,0 +1,143 @@ +Attribute VB_Name = "DevHelper" +Option Explicit + +Public Const TEST_FOLDER_ARTIFACTS = "test" +Public Const TEST_FOLDER_DB = "testAddin" + +Public Const TEST_FILE_MINIMAL = "MinimalDoc.docx" +Public Const TEST_FILE_001 = "001.docx" +Public Const TEST_FILE_002 = "002.docx" + +Public Function Dev_PrepareSkeleton() + ' Do nothing +End Function + +Public Sub Dev_ManualRunTest() + Dim sSuite$: sSuite = "s_InfoDocument" + Dim sTest$: sTest = "t_UpdateLinkTip" + 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_DocumentProcessor": Set Dev_GetTestSuite = New s_DocumentProcessor + Case "s_ItemHyperlink": Set Dev_GetTestSuite = New s_ItemHyperlink + Case "s_InfoDocument": Set Dev_GetTestSuite = New s_InfoDocument + Case "s_InfoWordDatabase": Set Dev_GetTestSuite = New s_InfoWordDatabase + Case "s_AddinAPI": Set Dev_GetTestSuite = New s_AddinAPI + Case "s_WordDataAccess": Set Dev_GetTestSuite = New s_WordDataAccess + End Select +End Function + +Public Function Dev_GetTestFolder() As String + Static sFolder$ + If sFolder = vbNullString Then + Dim fso As New Scripting.FileSystemObject + sFolder = fso.GetParentFolderName(ThisDocument.Path) + sFolder = sFolder & "\" & TEST_FOLDER_DB + End If + Dev_GetTestFolder = sFolder +End Function + +Public Function Dev_GetArtifactFolder() As String + Static sFolder$ + If sFolder = vbNullString Then + Dim fso As New Scripting.FileSystemObject + sFolder = fso.GetParentFolderName(ThisDocument.Path) + sFolder = sFolder & "\" & TEST_FOLDER_ARTIFACTS + End If + Dev_GetArtifactFolder = sFolder +End Function + +Public Function Dev_GetDatabaseTemplate() As String + Static sPath$ + If sPath = vbNullString Then + Dim fso As New Scripting.FileSystemObject + sPath = fso.GetParentFolderName(ThisDocument.Path) + sPath = sPath & "\" & HT03_DBNAME + End If + Dev_GetDatabaseTemplate = sPath$ +End Function + +Public Function Dev_SetupDatabaseFile() As String + Dim sTemplate$: sTemplate = Dev_GetDatabaseTemplate + Dim sTarget$: sTarget = Dev_GetTestFolder & "\" & HT03_DBNAME + + Call EnsureFolderExists(Dev_GetTestFolder & "\" & HT03_DEFAULT_WORKDIR) + Dim fso As New Scripting.FileSystemObject + Call fso.CopyFile(sTemplate, sTarget) + + Dev_SetupDatabaseFile = sTarget +End Function + +Public Function Dev_GetDatabase() As API_XLWrapper + Set Dev_GetDatabase = New API_XLWrapper + Call Dev_GetDatabase.CreateApplication + Call Dev_GetDatabase.OpenDocument(Dev_SetupDatabaseFile) +End Function + +Public Function Dev_SetupThreeLinks(iDoc As InfoDocument) + iDoc.linkSystem_ = PT_LOCAL + Call iDoc.UpdateStyles(ThisDocument.FullName) + + Dim doc As Word.Document: Set doc = iDoc.doc_ + Call doc.Range.InsertAfter("fillerStart" & vbNewLine & _ + "11 test1 11" & vbNewLine & _ + "22 test2 22" & vbNewLine & _ + "33 test3 33" & vbNewLine & _ + "fillerEnd" & vbNewLine) + + Dim iLink As New ItemLink + Call iLink.Init(0, "", 1337, "sub_1", T_LINK_ASPECT) + Call Dev_AssertTrue(iDoc.AddHyperlink(doc.Paragraphs(2).Range.Words(2), iLink, Style10)) + Call iLink.Init(0, "", 1338, "sub_2", T_LINK_DEFAULT) + Call Dev_AssertTrue(iDoc.AddHyperlink(doc.Paragraphs(3).Range.Words(2), iLink, Style10)) + Call iLink.Init(0, "", 1339, "sub_3", T_LINK_DEFINITION) + Call Dev_AssertTrue(iDoc.AddHyperlink(doc.Paragraphs(4).Range.Words(2), iLink, Style10)) +End Function + +Public Function GetDummyData() As ItemLaw + Set GetDummyData = New ItemLaw + With GetDummyData + .gid_ = GenerateGID + .status_ = T_LAWS_FULL + .type_ = T_LAW_05_CODEX + .fileName_ = "fileName" & CStr(.gid_) & ".docx" + .title_ = "title_" + .typeTxt_ = "typeTxt_" + .creator_ = "creator_" + .date_ = "date_" + .number_ = "number_" + .header_ = "header_" + .attach_ = "attach_" + .isScoped_ = True + .isDummy_ = False + End With +End Function + +Public Function GenerateLinks(Optional nCount& = 0) As String() + Dim lnkCount&: lnkCount = nCount + If lnkCount = 0 Then _ + lnkCount = Int((19 * Rnd) + 1) + Dim linksData() As String + ReDim linksData(1 To lnkCount, LinkTransferStruct.[_First] To LinkTransferStruct.[_Last]) + + Dim nItem& + For nItem = 1 To lnkCount Step 1 + linksData(nItem, S_TL_DESTINATION_ID) = CStr(GenerateGID) + linksData(nItem, S_TL_DESTINATION_SUB) = GenerateSub + linksData(nItem, S_TL_SOURCE_SUB) = GenerateSub + Next nItem + + GenerateLinks = linksData +End Function + +Public Function GenerateGID() As Long + GenerateGID = Int(9999 * Rnd) + 1000000 +End Function + +Public Function GenerateSub() As String + GenerateSub = "sub_" & Int(Rnd * 100) +End Function diff --git a/src/addin/DummyDocDlg.frm b/src/addin/DummyDocDlg.frm new file mode 100644 index 0000000..2a75190 --- /dev/null +++ b/src/addin/DummyDocDlg.frm @@ -0,0 +1,66 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} DummyDocDlg + Caption = " -" + ClientHeight = 1230 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 5895 + OleObjectBlob = "DummyDocDlg.frx":0000 + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "DummyDocDlg" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Explicit + +Public isCancelled_ As Boolean + +Private Sub UserForm_Initialize() + isCancelled_ = True + + Call cbDocType.AddItem("01. ") + Call cbDocType.AddItem("02. ") + Call cbDocType.AddItem("03. ") + Call cbDocType.AddItem("04. ") + Call cbDocType.AddItem("05. ") + Call cbDocType.AddItem("06. ") + Call cbDocType.AddItem("07. ") + Call cbDocType.AddItem("08. ") + Call cbDocType.AddItem("09. ") + Call cbDocType.AddItem("10. ") + Call cbDocType.AddItem("11. ") + Call cbDocType.AddItem("12. , , ") + + tbType.Value = 1 +End Sub + +Public Function GetType() As TLawType + GetType = cbDocType.ListIndex + 1 +End Function + +' ======= +Private Sub tbType_Change() + Dim txt$: txt = tbType.Text + If Not IsNumeric(txt) Then _ + Exit Sub + Dim val&: val = CLng(txt) + If val < 1 Or val > cbDocType.ListCount Then _ + Exit Sub + cbDocType.ListIndex = val - 1 +End Sub + +Private Sub cbDocType_Change() + tbType.Value = cbDocType.ListIndex + 1 +End Sub + +Private Sub cmdGo_Click() + isCancelled_ = False + Call Me.Hide +End Sub + +Private Sub cmdCancel_Click() + isCancelled_ = True + Call Me.Hide +End Sub diff --git a/src/addin/DummyDocDlg.frx b/src/addin/DummyDocDlg.frx new file mode 100644 index 0000000..cb569c7 Binary files /dev/null and b/src/addin/DummyDocDlg.frx differ diff --git a/src/addin/InfoWordDatabase.cls b/src/addin/InfoWordDatabase.cls new file mode 100644 index 0000000..159a4fe --- /dev/null +++ b/src/addin/InfoWordDatabase.cls @@ -0,0 +1,194 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "InfoWordDatabase" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public source_ As InfoDatabase + +Public Function Init(iDatabase As InfoDatabase) + Set source_ = iDatabase +End Function + +Public Function Contains(gid&) As Boolean + Contains = source_.Contains(gid) +End Function + +Public Function SyncLink(hLink As Word.Hyperlink, iDoc As InfoDocument) As IteratorLinkCached + Dim iLink As ItemHyperlink: Set iLink = ParseHyperlink(hLink) + Dim itLink As IteratorLinkCached: Set itLink = source_.LawLinksCached(iDoc.gid_) + If itLink Is Nothing Then _ + Call Err.Raise(ERR_INVALID_LINK_NUMBER) + + Dim linkNo&: linkNo = iDoc.CountLinksBefore(hLink.Range.End) + If Not itLink.Increment(linkNo - 1) Then _ + Call Err.Raise(ERR_SYNC_DB) + Call iLink.ValidateSync(itLink) + Set SyncLink = itLink +End Function + +Public Function LoadLinksFrom(target As InfoDocument) + Dim linkItems As Collection: Set linkItems = ExtractLinksData(target) + If linkItems.Count = 0 Then _ + Exit Function + + Dim linksData() As String + ReDim linksData(1 To linkItems.Count, LinkTransferStruct.[_First] To LinkTransferStruct.[_Last]) + Dim nItem& + Dim anItem As ItemLink + For nItem = 1 To linkItems.Count + Set anItem = linkItems(nItem) + linksData(nItem, S_TL_DESTINATION_ID) = CStr(anItem.destID_) + linksData(nItem, S_TL_DESTINATION_SUB) = anItem.destSub_ + linksData(nItem, S_TL_SOURCE_SUB) = anItem.sourceSub_ + Next nItem + + Call source_.SetLinksFor(target.gid_, linksData) +End Function + +Public Function ExpressLinks(target As InfoDocument) + Dim itLink As IteratorLinkCached: Set itLink = source_.LawLinksCached(target.gid_) + Dim aLink As Word.Hyperlink + For Each aLink In target.doc_.Hyperlinks + If Not IsHyperlinkValid(aLink) Then _ + GoTo NEXT_LNK + + If Not itLink.IsProcessed Then + If itLink.LType = T_LINK_DEFAULT Then _ + itLink.LType = T_LINK_DEFINITION + If IsGarantComment(aLink.Range.Paragraphs(1).Range) Then _ + itLink.Status = T_LINKS_IGNORE + End If + + Call itLink.Increment +NEXT_LNK: + Call CSE_ProgressBar.IncrementA + Next aLink +End Function + +Public Function ExpressDocuments(theType As TLawType, target As Word.Range) As Scripting.Dictionary + Dim newDocs As New Scripting.Dictionary + + Dim props As New ItemLaw + props.type_ = theType + props.status_ = T_LAWS_OUTER + + Dim newDoc As Word.Document + Dim aPar As Word.Paragraph + Dim iLink As ItemHyperlink + Dim theLink As Word.Hyperlink + For Each aPar In target.Paragraphs + For Each theLink In aPar.Range.Hyperlinks + Set iLink = ParseHyperlink(theLink) + If iLink Is Nothing Then _ + GoTo NEXT_LINK + + props.gid_ = iLink.DocumentID + props.title_ = ExtractTitleFromMention(aPar.Range) + props.isDummy_ = True + + If Not source_.Contains(props.gid_) Then + props.fileName_ = source_.GenerateFileName(props.title_) + Call AddDummyDocument(props, source_.docsLocation_, iLink.LinkSystem) + Call source_.SetItem(props) + Call newDocs.Add(iLink.DocumentID, 0) + End If + Exit For +NEXT_LINK: + Next theLink + Call CSE_ProgressBar.IncrementA + Next aPar + + Set ExpressDocuments = newDocs +End Function + +Public Function AddLinkAfter(iLink As ItemLink, nWhereIndex&) As Boolean + AddLinkAfter = source_.AddLinkAfter(iLink.sourceID_, nWhereIndex, iLink.destID_, iLink.destSub_, iLink.sourceSub_, iLink.type_) +End Function + +Public Function OpenHyperlink(target As Word.Hyperlink) As Boolean + OpenHyperlink = False + + Dim iLink As ItemHyperlink: Set iLink = ParseHyperlink(target) + If Not source_.Contains(iLink.DocumentID) Then _ + Call Err.Raise(EM_LINK_NO_FILE, iLink.ToAddress) + + Dim docIter As IteratorLaw: Set docIter = source_.Data(iLink.DocumentID) + Dim wordWrap As New API_WordWrapper + If wordWrap.OpenDocument(source_.docsLocation_ & "\" & docIter.FileName, bReadOnly:=True, bTrackMRU:=True) Is Nothing Then _ + Exit Function + + Dim sBookmark$: sBookmark = iLink.BookmarkName + With wordWrap.Document + If .Bookmarks.Exists(sBookmark) Then + Call .ActiveWindow.ScrollIntoView(.Bookmarks(sBookmark).Range) + Call .Bookmarks(sBookmark).Range.Select + ElseIf sBookmark <> "sub_0" Then + Call Err.Raise(EM_BOOKMARK_INVALID, sBookmark) + Else + Call .ActiveWindow.ScrollIntoView(.Range(1, 1)) + End If + End With + + OpenHyperlink = True +End Function + +' ========== +Private Function ExtractLinksData(target As InfoDocument) As Collection + Dim theLinks As New Collection + Dim iLink As ItemHyperlink + Dim docHLink As Word.Hyperlink + For Each docHLink In target.doc_.Hyperlinks + Set iLink = ParseHyperlink(docHLink) + If iLink Is Nothing Then _ + GoTo NEXT_LINK + + Dim subFrom$ + If docHLink.Range.Bookmarks.Count = 0 Then + subFrom = CreateBookmarkFor(docHLink.Range) + Else + subFrom = docHLink.Range.Bookmarks(1).Name + End If + + Dim anItem As ItemLink: Set anItem = New ItemLink + anItem.destID_ = iLink.DocumentID + anItem.destSub_ = iLink.BookmarkName + anItem.sourceSub_ = subFrom + + Call theLinks.Add(anItem) + +NEXT_LINK: + Call CSE_ProgressBar.IncrementA + Next docHLink + + Set ExtractLinksData = theLinks +End Function + +Private Function IsGarantComment(target As Word.Range) As Boolean + IsGarantComment = target.Style = "" +End Function + +Private Function ExtractTitleFromMention(ByRef target As Word.Range) As String + Call target.MoveStartWhile("[0123456789. ]") + Dim theText$: theText = target.Text + + Dim endPos&: endPos = Len(theText) + Dim pos1&: pos1 = InStr(1, UCase(theText), "", vbTextCompare) + If pos1 <> 0 And endPos > pos1 Then _ + endPos = pos1 - 3 + + Dim pos2&: pos2 = InStr(1, UCase(theText), "", vbTextCompare) + If pos2 <> 0 And endPos > pos2 Then _ + endPos = pos2 - 3 + + Dim pos3&: pos3 = InStr(1, UCase(theText), "", vbTextCompare) + If pos3 <> 0 And endPos > pos3 Then _ + endPos = pos3 - 3 + + ExtractTitleFromMention = SubstituteWhitespace(Left(theText, endPos)) +End Function diff --git a/src/addin/ItemDocumentProperties.cls b/src/addin/ItemDocumentProperties.cls new file mode 100644 index 0000000..211fbdd --- /dev/null +++ b/src/addin/ItemDocumentProperties.cls @@ -0,0 +1,26 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ItemDocumentProperties" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' Document properties +Option Explicit + +Public data_ As New ItemLaw +Public linkSystem_ As TLinkSystem +Public mods_ As ItemDocumentModification +Public killSource_ As Boolean + +Private Sub Class_Initialize() + linkSystem_ = PT_MOBILE + + Set mods_ = New ItemDocumentModification + mods_.deleteRevision_ = True + mods_.deleteComment_ = True + mods_.deleteImages_ = False + killSource_ = False +End Sub diff --git a/src/addin/ItemLinkModification.cls b/src/addin/ItemLinkModification.cls new file mode 100644 index 0000000..82ac4ed --- /dev/null +++ b/src/addin/ItemLinkModification.cls @@ -0,0 +1,23 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ItemLinkModification" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public newType_ As TLinkType + +Public seed_ As Word.Range +Public sourceLink_ As Word.Hyperlink +Public iterator_ As IteratorLinkCached + +Public applyToDocument_ As Boolean +Public spreadToSelected_ As Boolean + +Public Property Get FirstID() As Long + FirstID = iterator_.DestinationID +End Property diff --git a/src/addin/LinkToNewDocDlg.frm b/src/addin/LinkToNewDocDlg.frm new file mode 100644 index 0000000..a8cd929 --- /dev/null +++ b/src/addin/LinkToNewDocDlg.frm @@ -0,0 +1,174 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} LinkToNewDocDlg + Caption = " " + ClientHeight = 6285 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 9210.001 + OleObjectBlob = "LinkToNewDocDlg.frx":0000 + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "LinkToNewDocDlg" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Explicit + +Public isCancelled_ As Boolean + +Private database_ As InfoDatabase +Private source_ As InfoDocument +Private bms_ As Word.Bookmarks + +Private Sub UserForm_Initialize() + isCancelled_ = True + + Call PositionInMiddle(Me) + + Call cbDocType.AddItem("01. ") + Call cbDocType.AddItem("02. ") + Call cbDocType.AddItem("03. ") + Call cbDocType.AddItem("04. ") + Call cbDocType.AddItem("05. ") + Call cbDocType.AddItem("06. ") + Call cbDocType.AddItem("07. ") + Call cbDocType.AddItem("08. ") + Call cbDocType.AddItem("09. ") + Call cbDocType.AddItem("10. ") + Call cbDocType.AddItem("11. ") + Call cbDocType.AddItem("12. , , ") + + Call cbDocStatus.AddItem("1. : ") + Call cbDocStatus.AddItem("2. : ") + Call cbDocStatus.AddItem("3. : ") + Call cbDocStatus.AddItem("4. : ") + + tbType.Value = 1 + tbStatus.Value = 1 +End Sub + +Public Function Init(iSource As InfoDocument, theDB As InfoDatabase, existingBMs As Word.Bookmarks, sTitle$) + isCancelled_ = True + + Set database_ = theDB + Set source_ = iSource + Set bms_ = existingBMs + + tbTitle.Text = sTitle + Call InitSourceBookmarks + Call UpdateGID +End Function + +Public Function GetLink() As ItemLink + Set GetLink = New ItemLink + With GetLink + .sourceID_ = source_.gid_ + .sourceSub_ = cbSourceBookmark.Text + .destID_ = CLng(tbDocumentID.Text) + .destSub_ = tbSubTo.Text + .type_ = GetLinkType + End With +End Function + +Public Function GetDocument() As ItemLaw + Set GetDocument = ParseLawTitle(SubstituteWhitespace(tbTitle.Text)) + With GetDocument + .isDummy_ = True + .gid_ = CLng(tbDocumentID.Text) + .fileName_ = HT03_FILE_NOT_LOADED + .type_ = cbDocType.ListIndex + 1 + .status_ = cbDocStatus.ListIndex + 1 + .title_ = SubstituteWhitespace(tbTitle.Text) + End With +End Function + +' ============ +Private Sub btnGenerateID_Click() + Call UpdateGID +End Sub + +Private Sub tbStatus_Change() + Dim sStatus$: sStatus = tbStatus.Text + If Not IsNumeric(sStatus) Then _ + Exit Sub + Dim val&: val = CLng(sStatus) + If val < 1 Or val > cbDocStatus.ListCount Then _ + Exit Sub + cbDocStatus.ListIndex = val - 1 +End Sub + +Private Sub tbType_Change() + Dim sType$: sType = tbType.Text + If Not IsNumeric(sType) Then _ + Exit Sub + + Dim val&: val = CLng(sType) + If val < 1 Or val > cbDocType.ListCount Then _ + Exit Sub + + cbDocType.ListIndex = val - 1 +End Sub + +Private Sub cbDocStatus_Change() + tbStatus.Value = cbDocStatus.ListIndex + 1 +End Sub + +Private Sub cbDocType_Change() + tbType.Value = cbDocType.ListIndex + 1 +End Sub + +Private Sub btnCancel_Click() + isCancelled_ = True + Call Me.Hide +End Sub + +Private Sub btnOK_Click() + If Not ValidateBookmark Then + Call UserInteraction.ShowMessage(EM_BOOKMARK_NOT_AVAILABLE) + Exit Sub + End If + + isCancelled_ = False + Call Me.Hide +End Sub + +' ============ +Private Function UpdateGID() + tbDocumentID.Text = database_.GenerateID(tbTitle.Text) +End Function + +Private Function GetLinkType() As TLinkType + If optLevel0.Value = True Then + GetLinkType = T_LINK_DEFAULT + Exit Function + End If + If optLevel1.Value = True Then + GetLinkType = T_LINK_ASPECT + Exit Function + End If + If optLevel2.Value = True Then + GetLinkType = T_LINK_FOUNDATION + Exit Function + End If + If optLevel3.Value = True Then + GetLinkType = T_LINK_DEFINITION + Exit Function + End If +End Function + +Private Function InitSourceBookmarks() + Call cbSourceBookmark.Clear + Dim n& + For n = 1 To bms_.Count + Call cbSourceBookmark.AddItem(bms_.Item(n).Name) + Next n + If bms_.Count > 0 Then _ + cbSourceBookmark.Value = bms_.Item(1).Name +End Function + +Private Function ValidateBookmark() As Boolean + Dim sSub$: sSub = cbSourceBookmark.Text + ValidateBookmark = Not source_.doc_.Bookmarks.Exists(sSub) Or bms_.Exists(sSub) +End Function + diff --git a/src/addin/LinkToNewDocDlg.frx b/src/addin/LinkToNewDocDlg.frx new file mode 100644 index 0000000..bfb8ef1 Binary files /dev/null and b/src/addin/LinkToNewDocDlg.frx differ diff --git a/src/addin/LinkTypeDlg.frm b/src/addin/LinkTypeDlg.frm new file mode 100644 index 0000000..6e4c64f --- /dev/null +++ b/src/addin/LinkTypeDlg.frm @@ -0,0 +1,86 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} LinkTypeDlg + Caption = " " + ClientHeight = 4485 + ClientLeft = 45 + ClientTop = 375 + ClientWidth = 3765 + OleObjectBlob = "LinkTypeDlg.frx":0000 + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "LinkTypeDlg" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Explicit + +Private Const OPT_LT_PRE = "optLT" + +Public isCancelled_ As Boolean + +Private openFile_ As Boolean +Private link_ As TLinkType + +Private Sub UserForm_Initialize() + openFile_ = False + isCancelled_ = True + link_ = T_LINK_DEFAULT + + Call PositionInMiddle(Me) +End Sub + +Public Function Init(lnkType As TLinkType) + isCancelled_ = True + link_ = lnkType + openFile_ = False + btnAspekt.BackColor = IIf(lnkType = T_LINK_ASPECT, &HC0FFC0, &HC0FFFF) + btnConcrete.BackColor = IIf(lnkType = T_LINK_DEFINITION, &HC0FFC0, &HC0FFFF) + btnFoundation.BackColor = IIf(lnkType = T_LINK_FOUNDATION, &HC0FFC0, &HC0FFFF) +End Function + +Public Property Get NeedOpenFile() As Boolean + NeedOpenFile = openFile_ +End Property + +Public Property Get LType() As TLinkType + LType = link_ +End Property + +Property Get ApplyToAll() As Boolean + ApplyToAll = CheckBox1.Value +End Property + +Property Get ApplyToSelected() As Boolean + ApplyToSelected = CheckBox2.Value +End Property + +' =========== +Private Sub btnAspekt_Click() + link_ = T_LINK_ASPECT + isCancelled_ = False + Call Me.Hide +End Sub + +Private Sub btnConcrete_Click() + link_ = T_LINK_DEFINITION + isCancelled_ = False + Call Me.Hide +End Sub + +Private Sub btnFoundation_Click() + link_ = T_LINK_FOUNDATION + isCancelled_ = False + Call Me.Hide +End Sub + +Private Sub btnCancel_Click() + isCancelled_ = True + Call Me.Hide +End Sub + +Private Sub btnOpenGarant_Click() + openFile_ = True + isCancelled_ = False + Call Me.Hide +End Sub diff --git a/src/addin/LinkTypeDlg.frx b/src/addin/LinkTypeDlg.frx new file mode 100644 index 0000000..69fe3e3 Binary files /dev/null and b/src/addin/LinkTypeDlg.frx differ diff --git a/src/addin/Main.bas b/src/addin/Main.bas new file mode 100644 index 0000000..8f0697e --- /dev/null +++ b/src/addin/Main.bas @@ -0,0 +1,402 @@ +Attribute VB_Name = "Main" +' ========== UI subroutines ============ +Option Explicit + +Public Sub HT03_MergeID(nDelete&, nSubstitute&, sTitle$) + Call ExecuteLinksSubstitution(Word.Application.ActiveDocument, nDelete, nSubstitute, sTitle) +End Sub + +Public Sub HT03_AddOrUpdate() + Dim iDoc As InfoDocument: Set iDoc = ParseDocument(Word.Application.ActiveDocument) + If iDoc Is Nothing Then + Set iDoc = New InfoDocument + Set iDoc.doc_ = Word.Application.ActiveDocument + End If + + Dim theDB As InfoWordDatabase: Set theDB = AccessWordDatabase + If Not theDB.source_.Loaded Then _ + Exit Sub + + If Not theDB.Contains(iDoc.gid_) Then + Call AddLawInternal(iDoc, theDB) + Else + Call HT03_UpdateMarkup + End If +End Sub + +Public Sub HT03_AddDoc() + Dim iDoc As InfoDocument: Set iDoc = ParseDocument(Word.Application.ActiveDocument) + If iDoc Is Nothing Then + Set iDoc = New InfoDocument + Set iDoc.doc_ = Word.Application.ActiveDocument + End If + + Dim theDB As InfoWordDatabase: Set theDB = AccessWordDatabase + If Not theDB.source_.Loaded Then _ + Exit Sub + + Call AddLawInternal(iDoc, theDB) +End Sub + +Public Sub HT03_UpdateMarkup() + Dim iDoc As InfoDocument: Set iDoc = GetActiveDocument + If iDoc Is Nothing Then _ + Exit Sub + Dim theDB As InfoWordDatabase: Set theDB = AccessWordDatabase + If Not theDB.source_.Loaded Then _ + Exit Sub + + Dim sFile$: sFile = theDB.source_.Data(iDoc.gid_).FileName + If sFile <> iDoc.doc_.Name Then + Call UserInteraction.ShowMessage(EM_DOC_FILE_EXISTS, iDoc.gid_, sFile) + Exit Sub + End If + + Dim docUI As New API_WordWrapper: Call docUI.SetDocument(iDoc.doc_) + Call docUI.PauseUI + + On Error Resume Next + Call UpdateLinksIn(iDoc, theDB) + Call ProcessErrorMessages(UniqueList(ERR_SYNC_DOC, ERR_SYNC_DB, ERR_LINKS_MISSING, ERR_SYNC_LINK_ID)) + + Call docUI.ResumeUI +End Sub + +Public Sub HT03_EditDocument() + Dim iDoc As InfoDocument: Set iDoc = GetActiveDocument + If iDoc Is Nothing Then _ + Exit Sub + + Dim theDB As InfoWordDatabase: Set theDB = AccessWordDatabase + + Dim iLaw As ItemLaw: Set iLaw = theDB.source_.GetLawInfo(iDoc.gid_) + If iLaw Is Nothing Then + Set iLaw = iDoc.GetLawDescription() + Dim iter As IteratorLaw: Set iter = theDB.source_.Data(iDoc.gid_) + iLaw.status_ = iter.Status + iLaw.isDummy_ = iter.IsDummy + End If + + Dim props As ItemDocumentProperties: Set props = PromptLawProperties(iLaw, iDoc.linkSystem_, bEdit:=True) + If Not props Is Nothing Then _ + Call ProcessLawText(iDoc, theDB, props) +End Sub + +Public Sub HT03_NextLink() + Dim iDoc As InfoDocument: Set iDoc = GetActiveDocument + If iDoc Is Nothing Then _ + Exit Sub + + Dim theDB As InfoDatabase: Set theDB = AccessDatabase + If Not theDB.Cache(iDoc.gid_).HasLinks Then + Call UserInteraction.ShowMessage(EM_DOC_NO_LINKS) + Exit Sub + End If + + Dim iSelected As Word.Range: Set iSelected = ValidateSelectionRange(iDoc.doc_) + If iSelected Is Nothing Then _ + Exit Sub + Dim hLink As Word.Hyperlink: Set hLink = iDoc.FindNextUnresolved(iSelected.End) + If hLink Is Nothing Then + Call UserInteraction.ShowMessage(IM_DOC_LINKS_DONE) + Else + Call hLink.Range.Select + Call iDoc.doc_.ActiveWindow.ScrollIntoView(hLink.Range) + End If +End Sub + +Public Sub HT03_ChangeLType() + Dim iDoc As InfoDocument: Set iDoc = GetActiveDocument + If iDoc Is Nothing Then _ + Exit Sub + + Dim iSelected As Word.Range: Set iSelected = ValidateSelectionRange(iDoc.doc_) + If iSelected Is Nothing Then _ + Exit Sub + If iSelected.Hyperlinks.Count = 0 Then + Call UserInteraction.ShowMessage(EM_LINK_COUNT) + Exit Sub + End If + + On Error Resume Next + Dim bResult As Boolean: bResult = ModifyLinkType(iSelected, iDoc, AccessWordDatabase) + Call ProcessErrorMessages(UniqueList(ERR_INVALID_LINK_NUMBER, ERR_SYNC_DB, ERR_SYNC_LINK_ID)) + If Not bResult Then _ + Call UserInteraction.ShowMessage(EM_NO_VALID_LINKS) +End Sub + +Public Sub HT03_ChangeStatus() + Dim iDoc As InfoDocument: Set iDoc = GetActiveDocument + If iDoc Is Nothing Then _ + Exit Sub + + Dim iSelected As Word.Range: Set iSelected = ValidateSelectionRange(iDoc.doc_) + If iSelected Is Nothing Then _ + Exit Sub + If iSelected.Hyperlinks.Count = 0 Then + Call UserInteraction.ShowMessage(EM_LINK_COUNT) + Exit Sub + End If + + On Error Resume Next + Call ToggleLinksStatusIn(iSelected, iDoc, AccessWordDatabase) + Call ProcessErrorMessages(UniqueList(ERR_INVALID_LINK_NUMBER, ERR_SYNC_DB, ERR_SYNC_LINK_ID)) +End Sub + +Public Sub HT03_QueryLink() + Dim iDoc As InfoDocument: Set iDoc = GetActiveDocument + If iDoc Is Nothing Then _ + Exit Sub + + Dim iSelected As Word.Range: Set iSelected = ValidateSelectionRange(iDoc.doc_) + If iSelected Is Nothing Then _ + Exit Sub + Dim sLink$: sLink = iDoc.GetParagraphLink(iSelected) + If sLink = vbNullString Then + Call UserInteraction.ShowMessage(EM_NO_BOOKMARKS) + Else + Call AddToClipboard(sLink) + Call UserInteraction.ShowMessage(IM_QUERY_LINK, sLink) + End If +End Sub + +Public Sub HT03_ExpressLinks() + Dim iDoc As InfoDocument: Set iDoc = GetActiveDocument + If iDoc Is Nothing Then _ + Exit Sub + + Dim theDB As InfoWordDatabase: Set theDB = AccessWordDatabase + If Not theDB.source_.Cache(iDoc.gid_).HasLinks Then + Call UserInteraction.ShowMessage(EM_DOC_NO_LINKS) + Exit Sub + End If + + Call CSE_ProgressBar.Init(" ", sHeader:="", maxVal:=iDoc.doc_.Hyperlinks.Count, curVal:=1) + Call CSE_ProgressBar.ShowModeless + Call theDB.ExpressLinks(iDoc) + Call Unload(CSE_ProgressBar) + + Call HT03_UpdateMarkup +End Sub + +Public Sub HT03_ExpressDocuments() + Dim iDoc As InfoDocument: Set iDoc = GetActiveDocument + If iDoc Is Nothing Then _ + Exit Sub + Dim iSelected As Word.Range: Set iSelected = ValidateSelectionRange(iDoc.doc_) + If iSelected Is Nothing Then + Exit Sub + ElseIf iSelected.Hyperlinks.Count = 0 Then + Call UserInteraction.ShowMessage(EM_LINK_COUNT) + Exit Sub + End If + + Call DummyDocDlg.Show + If DummyDocDlg.isCancelled_ Then _ + Exit Sub + Dim newType As TLawType: newType = DummyDocDlg.GetType + Call Unload(DummyDocDlg) + + Dim theDB As InfoWordDatabase: Set theDB = AccessWordDatabase + + Call CSE_ProgressBar.Init(" ", maxVal:=iSelected.Hyperlinks.Count, curVal:=0) + Call CSE_ProgressBar.ShowModeless + Dim docs As Scripting.Dictionary: Set docs = theDB.ExpressDocuments(newType, iSelected) + Call Unload(CSE_ProgressBar) + + If docs.Count <> 0 Then + On Error Resume Next + Call iDoc.UpdateFormatFilter(docs, theDB.source_) + Call ProcessErrorMessages(UniqueList(ERR_SYNC_LINK_ID)) + End If + Call UserInteraction.ShowMessage(IM_DOC_EXPRESS_ADD, docs.Count) +End Sub + +Public Sub HT03_RejectDocument() + Dim iDoc As InfoDocument: Set iDoc = GetActiveDocument + If iDoc Is Nothing Then _ + Exit Sub + Dim iSelected As Word.Range: Set iSelected = ValidateSelectionRange(iDoc.doc_) + If iSelected Is Nothing Then _ + Exit Sub + + Dim nCount&: nCount = IgnoreLawsIn(iSelected, iDoc, AccessDatabase) + If nCount = 0 Then + Call UserInteraction.ShowMessage(EM_LINK_COUNT) + Else + Call UserInteraction.ShowMessage(IM_DOC_IGNORED, nCount) + End If +End Sub + +Public Sub HT03_AddLink() + Dim iDoc As InfoDocument: Set iDoc = GetActiveDocument + If iDoc Is Nothing Then _ + Exit Sub + Dim iSelected As Word.Range: Set iSelected = EnsureNoLinksSelected(iDoc.doc_) + If iSelected Is Nothing Then _ + Exit Sub + + Dim theDB As InfoWordDatabase: Set theDB = AccessWordDatabase + If Not theDB.source_.HasLinksFor(iDoc.gid_) Then + Call UserInteraction.ShowMessage(EM_HAS_NO_LINKS) + Exit Sub + End If + + Dim newLnk As ItemLink: Set newLnk = PromptNewLink(iSelected, iDoc, theDB.source_) + If newLnk Is Nothing Then _ + Exit Sub + + On Error Resume Next + Call AddLinkTo(iSelected, newLnk, iDoc, theDB) + Call ProcessErrorMessages(UniqueList(ERR_ADD_LINK_DOC_FAILED, ERR_ADD_LINK_DB_FAILED, ERR_LINK_SELF)) +End Sub + +Public Sub HT03_AddNew() + Dim iDoc As InfoDocument: Set iDoc = GetActiveDocument + If iDoc Is Nothing Then _ + Exit Sub + Dim iSelected As Word.Range: Set iSelected = EnsureNoLinksSelected(iDoc.doc_) + If iSelected Is Nothing Then _ + Exit Sub + + Dim theDB As InfoWordDatabase: Set theDB = AccessWordDatabase + If Not theDB.source_.HasLinksFor(iDoc.gid_) Then + Call UserInteraction.ShowMessage(EM_HAS_NO_LINKS) + Exit Sub + End If + + Dim newLnk As ItemLink: Set newLnk = PromptLinkToNewDoc(iSelected, iDoc, theDB.source_) + If newLnk Is Nothing Then _ + Exit Sub + + On Error Resume Next + Call AddLinkTo(iSelected, newLnk, iDoc, theDB) + Call ProcessErrorMessages(UniqueList(ERR_ADD_LINK_DOC_FAILED, ERR_ADD_LINK_DB_FAILED, ERR_LINK_SELF)) +End Sub + +Public Sub HT03_RemoveLink() + Dim iDoc As InfoDocument: Set iDoc = GetActiveDocument + If iDoc Is Nothing Then _ + Exit Sub + + Dim iSelected As Word.Range: Set iSelected = ValidateSelectionRange(iDoc.doc_) + If iSelected Is Nothing Then _ + Exit Sub + If iSelected.Hyperlinks.Count = 0 Then + Call UserInteraction.ShowMessage(EM_LINK_COUNT) + Exit Sub + ElseIf iSelected.Hyperlinks(1).Range.Start = 0 Then + Call UserInteraction.ShowMessage(EM_REMOVE_FIRST_LINK) + Exit Sub + End If + + On Error Resume Next + Dim nCount&: nCount = RemoveLinksIn(iSelected, iDoc, AccessDatabase) + Call ProcessErrorMessages(UniqueList(ERR_SYNC_LINK_ID, ERR_SYNC_DB)) + + Call UserInteraction.ShowMessage(IM_REMOVE_LINK_OK, nCount) +End Sub + +Public Sub HT03_FollowLink() + Dim selectedLinks As Word.Hyperlinks: Set selectedLinks = ActiveDocument.Application.Selection.Hyperlinks + If selectedLinks.Count <> 1 Then + Call UserInteraction.ShowMessage(EM_LINK_SINGLE) + Exit Sub + End If + + Dim hLink As Word.Hyperlink: Set hLink = selectedLinks(1) + If Not IsHyperlinkValid(hLink) Then + Call UserInteraction.ShowMessage(EM_LINK_INVALID) + Exit Sub + End If + + On Error Resume Next + Call AccessWordDatabase.OpenHyperlink(hLink) + Call ProcessErrorMessages(UniqueList(ERR_LINK_NO_FILE, ERR_BOOKMARK_INVALID)) +End Sub + +Public Sub HT03_Registry() + Dim dbDoc As Excel.Workbook: Set dbDoc = GetDatabaseDocument(Word.Application.ActiveDocument) + If dbDoc Is Nothing Then _ + Exit Sub + + Call dbDoc.Activate + dbDoc.Application.WindowState = xlMaximized + Call AppActivate(dbDoc.Application.Caption) +End Sub + +Public Sub HT03_ReloadIndex() + Call AccessDatabase.Recreate + Call MsgBox(" ", vbInformation) +End Sub + +Public Sub HT03_Help() + Dim wordWrap As New API_WordWrapper + Dim helpDoc As Word.Document: Set helpDoc = wordWrap.OpenDocument(HELP_FILE_PATH, bReadOnly:=True) + If helpDoc Is Nothing Then + Call UserInteraction.ShowMessage(EM_HELP_FILE_INVALID, HELP_FILE_PATH) + Exit Sub + End If + + With helpDoc + .ActiveWindow.View.ReadingLayout = False + Call .ActiveWindow.ScrollIntoView(helpDoc.Bookmarks(HELP_WORD_BOOKMARK).Range) + Call .Application.Activate + End With +End Sub + +Public Sub HT03_ReloadLinks() + Dim iDoc As InfoDocument: Set iDoc = GetActiveDocument + If iDoc Is Nothing Then _ + Exit Sub + Dim theDB As InfoWordDatabase: Set theDB = AccessWordDatabase + If Not theDB.source_.Loaded Then _ + Exit Sub + + If Not UserInteraction.AskQuestion(QM_RELOAD_CONFIRM) Then _ + Exit Sub + + Call ReloadLinks(iDoc, theDB) + Call HT03_UpdateMarkup +End Sub + +' =========================== +Private Function GetActiveDocument() As InfoDocument + Dim iDoc As New InfoDocument: Set iDoc = ParseDocument(Word.Application.ActiveDocument) + If iDoc Is Nothing Then + Call UserInteraction.ShowMessage(EM_DOC_NOT_ADDED) + Exit Function + End If + + Dim theDB As InfoDatabase: Set theDB = AccessDatabase + If Not theDB.Loaded Then _ + Exit Function + If Not theDB.Contains(iDoc.gid_) Then + Call UserInteraction.ShowMessage(EM_DOC_NOT_ADDED) + Exit Function + End If + + If theDB.Data(iDoc.gid_).FileName = HT03_FILE_NOT_LOADED Then + Call UserInteraction.ShowMessage(EM_DOC_NOT_ADDED) + Exit Function + End If + + Set GetActiveDocument = iDoc +End Function + +Private Function AddLawInternal(ByRef iDoc As InfoDocument, theDB As InfoWordDatabase) + Dim iLaw As ItemLaw: Set iLaw = PrepareNewLaw(iDoc, theDB) + If iLaw Is Nothing Then _ + Exit Function + + If Not theDB.source_.FindByFileName(iDoc.doc_.Name) Is Nothing Then + Call UserInteraction.ShowMessage(EM_FILENAME_TAKEN) + Exit Function + End If + + Dim theProps As ItemDocumentProperties: Set theProps = PromptLawProperties(iLaw, iDoc.linkSystem_, bEdit:=False) + If theProps Is Nothing Then _ + Exit Function + + Call AddNewLaw(iDoc, theDB, theProps) +End Function diff --git a/src/addin/MainImpl.bas b/src/addin/MainImpl.bas new file mode 100644 index 0000000..1310f41 --- /dev/null +++ b/src/addin/MainImpl.bas @@ -0,0 +1,410 @@ +Attribute VB_Name = "MainImpl" +' Main logic implementation +Option Private Module +Option Explicit + +Public Function ValidateSelectionRange(target As Word.Document) As Word.Range + Dim iSelected As Word.Range: Set iSelected = target.Application.Selection.Range + If iSelected.StoryType <> wdMainTextStory Then + Call UserInteraction.ShowMessage(EM_SELECTION_NOT_IN_MAIN) + Exit Function + End If + Set ValidateSelectionRange = iSelected +End Function + +Public Function EnsureNoLinksSelected(target As Word.Document) As Word.Range + Dim iSelected As Word.Range: Set iSelected = ValidateSelectionRange(target) + If iSelected Is Nothing Then + Exit Function + ElseIf iSelected.Hyperlinks.Count <> 0 Then + Call UserInteraction.ShowMessage(EM_LINKS_NOT_ZERO) + Exit Function + ElseIf iSelected.Start = iSelected.End Then + Call UserInteraction.ShowMessage(EM_SELECTION_INVALID) + Exit Function + ElseIf iSelected.Paragraphs.Count <> 1 Then + Call UserInteraction.ShowMessage(EM_PARAGRAPH_MULTIPLE) + Exit Function + End If + Set EnsureNoLinksSelected = iSelected +End Function + +Public Function PrepareNewLaw(iDoc As InfoDocument, theDB As InfoWordDatabase) As ItemLaw + Dim iLaw As ItemLaw: Set iLaw = iDoc.GetLawDescription + iLaw.isDummy_ = False + iLaw.status_ = T_LAWS_FULL + + If Not theDB.Contains(iDoc.gid_) Then _ + GoTo RETURN_TRUE + + Dim docIter As IteratorLaw: Set docIter = theDB.source_.Data(iDoc.gid_) + Dim sFile$: sFile = docIter.FileName + If sFile = HT03_FILE_NOT_LOADED Then _ + GoTo RETURN_TRUE + + If sFile = iDoc.doc_.Name And theDB.source_.docsLocation_ = iDoc.doc_.Path Then + Call UserInteraction.ShowMessage(EM_FILE_ALREADY_ADDED) + Exit Function + End If + + If docIter.IsDummy Then + If Not UserInteraction.AskQuestion(QM_DELETE_BEFORE_ADD_DUMMY, iDoc.gid_) Then _ + Exit Function + Else + If Not UserInteraction.AskQuestion(QM_DELETE_BEFORE_ADD, iDoc.gid_) Then _ + Exit Function + End If + + iLaw.type_ = docIter.DType + If docIter.Status <> T_LAWS_OUTER Then _ + iLaw.status_ = docIter.Status + + Call theDB.source_.DeleteLaw(iDoc.gid_) + +RETURN_TRUE: + iLaw.fileName_ = theDB.source_.GenerateFileName(iLaw.title_) + Set PrepareNewLaw = iLaw +End Function + +Public Function AddNewLaw(iDoc As InfoDocument, theDB As InfoWordDatabase, theProps As ItemDocumentProperties) + iDoc.linkSystem_ = theProps.linkSystem_ + If iDoc.gid_ = HT03_INVALID_GID Then + iDoc.gid_ = theProps.data_.gid_ + If Not UserInteraction.AskQuestion(QM_ADD_TITLELINK, iDoc.gid_) Then _ + Exit Function + Call iDoc.CreateTitleLink + End If + + Call iDoc.UpdateStyles(ThisDocument.FullName) + Call ProcessLawText(iDoc, theDB, theProps) + Call EnsureDocSaved(iDoc.doc_, theProps.data_.fileName_, theProps.killSource_) +End Function + +Public Function UpdateLinksIn(iDoc As InfoDocument, theDB As InfoWordDatabase) + Dim iLaw As ItemCachedLaw: Set iLaw = theDB.source_.Cache(iDoc.gid_) + If iLaw.status_ = T_LAWS_OUTER Then + Call UserInteraction.ShowMessage(IM_SCAN_MODE) + Exit Function + End If + If iLaw.status_ = T_LAWS_IGNORE Then + Call UserInteraction.ShowMessage(IM_IGNORE_MODE) + Exit Function + End If + If Not theDB.source_.HasLinksFor(iDoc.gid_) Then + If UserInteraction.AskQuestion(QM_RELOAD_ON_UPDATE, iDoc.gid_) Then + Call ReloadLinks(iDoc, theDB) + Else + Exit Function + End If + End If + + Call CSE_ProgressBar.Init(" ", sHeader:=" ...", maxVal:=iDoc.doc_.Hyperlinks.Count) + Call CSE_ProgressBar.ShowModeless + + Dim nUnresolved&: nUnresolved = iDoc.UpdateFormat(theDB.source_) + + Dim sTime$: sTime = CSE_ProgressBar.TimeStr + Call Unload(CSE_ProgressBar) + + If nUnresolved <> 0 Then + Call UserInteraction.ShowMessage(IM_LINKS_TODO, nUnresolved, sTime) + Else + Call UserInteraction.ShowMessage(IM_LINKS_DONE, sTime) + End If +End Function + +Public Function ModifyLinkType(target As Word.Range, iDoc As InfoDocument, theDB As InfoWordDatabase) As Boolean + ModifyLinkType = False + + Dim firstLink As Word.Hyperlink: Set firstLink = GetFirstValidHyperlinkIn(target) + If firstLink Is Nothing Then _ + Exit Function + + Dim itLink As IteratorLinkCached: Set itLink = theDB.SyncLink(firstLink, iDoc) + Dim targetID&: targetID = itLink.DestinationID + Dim iMod As ItemLinkModification: Set iMod = PromptLinkType(itLink.LType, targetID, firstLink.Address) + If iMod Is Nothing Then + ModifyLinkType = True + Exit Function + End If + + If Not theDB.Contains(targetID) Then _ + If UserInteraction.AskQuestion(QM_OPEN_GARANT, targetID) Then _ + Call UserInteraction.FollowHyperlink(iDoc.doc_, firstLink.Address) + + Set iMod.seed_ = target + Set iMod.sourceLink_ = firstLink + Set iMod.iterator_ = itLink + + Call ApplyLinkTypeModification(iMod, iDoc, theDB.source_) + ModifyLinkType = True +End Function + +Public Function ToggleLinksStatusIn(target As Word.Range, iDoc As InfoDocument, theDB As InfoWordDatabase) + Dim itLink As IteratorLinkCached + Dim docHLink As Word.Hyperlink + For Each docHLink In target.Hyperlinks + If IsHyperlinkValid(docHLink) Then + Set itLink = theDB.SyncLink(docHLink, iDoc) + Call itLink.FlipStatus + Call iDoc.ApplyLinkStatus(docHLink, itLink.Status) + End If + Next docHLink +End Function + +Public Function IgnoreLawsIn(target As Word.Range, iDoc As InfoDocument, theDB As InfoDatabase) As Long + IgnoreLawsIn = 0 + If target.Hyperlinks.Count = 0 Then _ + Exit Function + + Dim iLink As ItemHyperlink + Dim docHLink As Word.Hyperlink + Dim docsToIgnore As New Scripting.Dictionary + For Each docHLink In target.Hyperlinks + Set iLink = ParseHyperlink(docHLink) + If iLink Is Nothing Then _ + GoTo NEXT_LINK + If Not theDB.IgnoreLaw(iLink.DocumentID) Then _ + GoTo NEXT_LINK + + Call docsToIgnore.Add(iLink.DocumentID, 0) + IgnoreLawsIn = IgnoreLawsIn + 1 +NEXT_LINK: + Next docHLink + + Call iDoc.IgnoreLawLinks(docsToIgnore) +End Function + +Public Function ProcessLawText(target As InfoDocument, theDB As InfoWordDatabase, props As ItemDocumentProperties) + Dim docUI As New API_WordWrapper: Call docUI.SetDocument(target.doc_) + Call docUI.PauseUI + + Dim newItem As ItemCachedLaw: Set newItem = theDB.source_.SetItem(props.data_) + If newItem.HasLinks And Not theDB.source_.HasLinksFor(target.gid_) Then + Call CSE_ProgressBar.Init(" ", sHeader:=" ...") + Call CSE_ProgressBar.ShowModeless + + Call PrepareDocumentText(target.doc_, props.mods_) + Call ReloadLinks(target, theDB) + End If + + On Error Resume Next + Call UpdateLinksIn(target, theDB) + Call ProcessErrorMessages(UniqueList(ERR_SYNC_DOC, ERR_SYNC_DB)) + On Error GoTo 0 + + Call docUI.ResumeUI +End Function + +Public Function RemoveLinksIn(target As Word.Range, iDoc As InfoDocument, theDB As InfoDatabase) As Long + Dim nStart&: nStart = iDoc.CountLinksBefore(target.Start) + 1 + If nStart < 1 Then _ + Exit Function + Dim itLink As IteratorLinkCached: Set itLink = theDB.LawLinksCached(iDoc.gid_) + If itLink Is Nothing Then _ + Exit Function + + If Not itLink.Increment(nStart - 1) Then _ + Call Err.Raise(ERR_SYNC_DB) + + Dim nCount&: nCount = 0 + + Dim bNoMoreLinks As Boolean: bNoMoreLinks = False + Dim docHLink As Word.Hyperlink + For Each docHLink In target.Hyperlinks + Dim iLink As ItemHyperlink: Set iLink = ParseHyperlink(docHLink) + If iLink Is Nothing Then _ + GoTo NEXT_LINK + If bNoMoreLinks Then _ + Call Err.Raise(ERR_SYNC_DB) + Call iLink.ValidateSync(itLink) + + nCount = nCount + 1 + bNoMoreLinks = Not itLink.Increment +NEXT_LINK: + Next docHLink + + If nCount = 0 Then _ + Exit Function + + RemoveLinksIn = nCount + Call theDB.DeleteSomeLinksFor(iDoc.gid_, nStart, nCount) + Call iDoc.RemoveLinksFrom(target) +End Function + +' Requires: target range should have no hyperlinks +Public Function AddLinkTo(target As Word.Range, iLink As ItemLink, iDoc As InfoDocument, theDB As InfoWordDatabase) + Debug.Assert target.Hyperlinks.Count = 0 + + If iLink.destID_ = iLink.sourceID_ Then _ + Call Err.Raise(EM_LINK_SELF) + If iLink.destSub_ = vbNullString Then _ + iLink.destSub_ = "sub_0" + If iLink.sourceSub_ = vbNullString Then _ + iLink.sourceSub_ = CreateBookmarkFor(target.Paragraphs(1).Range) + + Dim sStyle$: sStyle = GetLinkStatusStyle(theDB.source_.Cache(iLink.sourceID_).status_, theDB.source_.GetLawStatus(iLink.destID_), iLink.type_) + If Not iDoc.AddHyperlink(target, iLink, sStyle) Then _ + Call Err.Raise(EM_ADD_LINK_DOC_FAILED) + + Dim nLink&: nLink = iDoc.CountLinksBefore(target.Start) + If Not theDB.AddLinkAfter(iLink, nLink) Then + target.Hyperlinks(1).Range.Style = wdStyleDefaultParagraphFont + Call target.Hyperlinks(1).Delete + Call Err.Raise(EM_ADD_LINK_DB_FAILED) + End If +End Function + +Public Function PromptLawProperties(iLaw As ItemLaw, nSystem As TLinkSystem, bEdit As Boolean) As ItemDocumentProperties + With NewDocumentDlg + Call .Init(iLaw, nSystem, bEdit) + Call .Show + If Not .isCancelled_ Then _ + Set PromptLawProperties = .Properties + End With + Call Unload(NewDocumentDlg) +End Function + +Public Function PromptLinkType(oldType As TLinkType, gid&, sAddress$) As ItemLinkModification + Dim iMod As New ItemLinkModification + With LinkTypeDlg + Call .Init(oldType) + Call .Show + + If .isCancelled_ Then _ + Exit Function + If .NeedOpenFile Then + Call UserInteraction.FollowHyperlink(ActiveDocument, sAddress) + Exit Function + End If + + iMod.applyToDocument_ = .ApplyToAll + iMod.spreadToSelected_ = .ApplyToSelected + iMod.newType_ = .LType + End With + Call Unload(LinkTypeDlg) + + Set PromptLinkType = iMod +End Function + +Public Function PromptNewLink(rAnchor As Word.Range, iDoc As InfoDocument, theDB As InfoDatabase) As ItemLink + Call NewLinkDlg.Init(iDoc, theDB, rAnchor.Bookmarks) + Call NewLinkDlg.Show + If NewLinkDlg.isCancelled_ Then _ + Exit Function + + Set PromptNewLink = NewLinkDlg.GetLink + Call Unload(NewLinkDlg) +End Function + +Public Function PromptLinkToNewDoc(rAnchor As Word.Range, iDoc As InfoDocument, theDB As InfoDatabase) As ItemLink + Call LinkToNewDocDlg.Init(iDoc, theDB, rAnchor.Bookmarks, rAnchor.Text) + Call LinkToNewDocDlg.Show + If LinkToNewDocDlg.isCancelled_ Then _ + Exit Function + + Dim iNewDoc As ItemLaw: Set iNewDoc = LinkToNewDocDlg.GetDocument + Call theDB.SetItem(iNewDoc) + Set PromptLinkToNewDoc = LinkToNewDocDlg.GetLink + Call Unload(LinkToNewDocDlg) +End Function + +Public Function ReloadLinks(target As InfoDocument, theDB As InfoWordDatabase) + Call CSE_ProgressBar.Init(CSE_ProgressBar.Title, sHeader:=" ...", maxVal:=target.doc_.Hyperlinks.Count, curVal:=1) + Call theDB.LoadLinksFrom(target) + Call Unload(CSE_ProgressBar) +End Function + +Public Function ExecuteLinksSubstitution(iDoc As Word.Document, nDelete&, nSubstitute&, sTitle$) + Dim iLink As ItemHyperlink + Dim docHLink As Word.Hyperlink + For Each docHLink In iDoc.Hyperlinks + Set iLink = ParseHyperlink(docHLink) + If iLink Is Nothing Then _ + GoTo NEXT_LINK + If iLink.DocumentID = nDelete Then + iLink.DocumentID = nSubstitute + docHLink.Address = iLink.ToAddress + docHLink.ScreenTip = sTitle + End If + +NEXT_LINK: + Next docHLink +End Function + +' ======================== +Private Function EnsureDocSaved(target As Word.Document, theFile$, killSource As Boolean) + Dim dbDir$: dbDir = AccessDatabase.docsLocation_ + Dim newFullName$: newFullName = dbDir & "\" & theFile + Dim oldFullName$: oldFullName = target.FullName + If newFullName = oldFullName Then _ + Exit Function + + Dim fso As New Scripting.FileSystemObject + Call EnsureFolderExists(fso.GetParentFolderName(newFullName)) + Dim removeOld As Boolean: removeOld = killSource Or target.Path = dbDir + With target + .SpellingChecked = True + .GrammarChecked = True + .Range.NoProofing = True + Call .SaveAs(newFullName, FileFormat:=wdFormatDocumentDefault) + End With + If removeOld Then _ + Call Kill(oldFullName) +End Function + +Private Function ApplyLinkTypeModification(iMod As ItemLinkModification, iDoc As InfoDocument, theDB As InfoDatabase) + Dim sSource As TLawStatus: sSource = theDB.GetLawStatus(iDoc.gid_) + iMod.iterator_.Status = T_LINKS_ADD + If Not iMod.applyToDocument_ Then + If Not iMod.spreadToSelected_ Then + iMod.iterator_.LType = iMod.newType_ + Call iDoc.FormatLink(iMod.sourceLink_, iMod.newType_, T_LINKS_ADD, sSource, theDB.GetLawStatus(iMod.FirstID)) + Else + Call ModifyLinksTypeIn(iMod.seed_, iMod.iterator_, iMod.newType_, sSource, iDoc, theDB) + End If + Else + Dim targetDocs As Scripting.Dictionary + If Not iMod.spreadToSelected_ Then + Set targetDocs = New Scripting.Dictionary + Call targetDocs.Add(iMod.FirstID, theDB.GetLawStatus(iMod.FirstID)) + Else + Set targetDocs = ScanLawIDs(iMod.seed_) + Call theDB.FillLawsStatus(targetDocs) + End If + Call ModifyLinksTypeAll(targetDocs, iMod.iterator_, iMod.newType_, sSource, iDoc) + End If +End Function + +Private Function ModifyLinksTypeIn(target As Word.Range, itLink As IteratorLinkCached, nType As TLinkType, sSource As TLawStatus, iDoc As InfoDocument, theDB As InfoDatabase) + Dim docHLink As Word.Hyperlink + Dim iLink As ItemHyperlink + For Each docHLink In target.Hyperlinks + Set iLink = ParseHyperlink(docHLink) + If Not iLink Is Nothing Then + Dim targetID&: targetID = iLink.DocumentID + itLink.LType = nType + Call iDoc.FormatLink(docHLink, nType, itLink.Status, sSource, theDB.GetLawStatus(targetID)) + If Not itLink.Increment Then _ + Exit Function + End If + Next docHLink +End Function + +Private Function ModifyLinksTypeAll(targetDocs As Scripting.Dictionary, itLink As IteratorLinkCached, nType As TLinkType, sSource As TLawStatus, iDoc As InfoDocument) + Call itLink.GoFirst + Dim docHLink As Word.Hyperlink + Dim iLink As ItemHyperlink + For Each docHLink In iDoc.doc_.Hyperlinks + Set iLink = ParseHyperlink(docHLink) + If Not iLink Is Nothing Then + Dim targetID&: targetID = iLink.DocumentID + If targetDocs.Exists(targetID) Then + itLink.LType = nType + Call iDoc.FormatLink(docHLink, nType, itLink.Status, sSource, targetDocs(targetID)) + End If + If Not itLink.Increment Then _ + Exit Function + End If + Next docHLink +End Function diff --git a/src/addin/NewDocumentDlg.frm b/src/addin/NewDocumentDlg.frm new file mode 100644 index 0000000..d36b1f5 --- /dev/null +++ b/src/addin/NewDocumentDlg.frm @@ -0,0 +1,189 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} NewDocumentDlg + Caption = " " + ClientHeight = 8670.001 + ClientLeft = 45 + ClientTop = 375 + ClientWidth = 9210.001 + OleObjectBlob = "NewDocumentDlg.frx":0000 + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "NewDocumentDlg" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Explicit + +Private Const OPT_LEVEL_PRE = "optLevel" +Private Const OPT_STATUS_PRE = "OBStatus" + +Private isNewID_ As Boolean +Private isDummy_ As Boolean + +Public isCancelled_ As Boolean + +Private Sub UserForm_Initialize() + isCancelled_ = True + isNewID_ = False + + Call cbDocType.AddItem("01. ") + Call cbDocType.AddItem("02. ") + Call cbDocType.AddItem("03. ") + Call cbDocType.AddItem("04. ") + Call cbDocType.AddItem("05. ") + Call cbDocType.AddItem("06. ") + Call cbDocType.AddItem("07. ") + Call cbDocType.AddItem("08. ") + Call cbDocType.AddItem("09. ") + Call cbDocType.AddItem("10. ") + Call cbDocType.AddItem("11. ") + Call cbDocType.AddItem("12. , , ") + + Call cbDocStatus.AddItem("1. : ") + Call cbDocStatus.AddItem("2. : ") + Call cbDocStatus.AddItem("3. : ") + Call cbDocStatus.AddItem("4. : ") + + Call cbPrefixType.AddItem("") + Call cbPrefixType.AddItem("") + Call cbPrefixType.AddItem("") + + tbType.Value = 1 + tbStatus.Value = 1 + + Call PositionInMiddle(Me) +End Sub + +Public Function Init(iLaw As ItemLaw, nSystem As TLinkSystem, bEdit As Boolean) + isCancelled_ = True + isNewID_ = iLaw.gid_ = HT03_INVALID_GID + isDummy_ = iLaw.isDummy_ + + tbGID.Text = CStr(iLaw.gid_) + tbType.Value = iLaw.type_ + cbDocType.ListIndex = iLaw.type_ - 1 + tbStatus.Value = iLaw.status_ + cbDocStatus.ListIndex = iLaw.status_ - 1 + tbFileName.Text = iLaw.fileName_ + tbTitle.Text = iLaw.title_ + tbTypeText.Text = iLaw.typeTxt_ + tbCreator.Text = iLaw.creator_ + tbDate.Text = iLaw.date_ + tbNumber.Text = iLaw.number_ + tbHeader.Text = iLaw.header_ + tbAttach.Text = iLaw.attach_ + cbImmediate.Value = iLaw.isScoped_ + + cbPrefixType.ListIndex = SystemIndexFor(nSystem) + + cbDeleteSource.Enabled = Not bEdit + tbFileName.Enabled = Not bEdit + + Call UpdateGID +End Function + +Property Get Properties() As ItemDocumentProperties + Set Properties = New ItemDocumentProperties + With Properties + .data_.gid_ = CLng(tbGID.Text) + .data_.type_ = cbDocType.ListIndex + 1 + .data_.status_ = cbDocStatus.ListIndex + 1 + .data_.title_ = SubstituteWhitespace(tbTitle.Text) + .data_.fileName_ = Trim(tbFileName.Text) + .data_.typeTxt_ = Trim(tbTypeText.Text) + .data_.creator_ = Trim(tbCreator.Text) + .data_.date_ = Trim(tbDate.Text) + .data_.number_ = Trim(tbNumber.Text) + .data_.header_ = Trim(tbHeader.Text) + .data_.attach_ = Trim(tbAttach.Text) + .data_.isScoped_ = cbImmediate.Value + .data_.isDummy_ = isDummy_ + + .linkSystem_ = SystemTypeFor(cbPrefixType.ListIndex) + .mods_.deleteRevision_ = CBDeleteChange.Value + .mods_.deleteComment_ = CBDelComment.Value + .mods_.deleteImages_ = CBDeleteImages.Value + .killSource_ = cbDeleteSource.Value + End With +End Property + +' =================== +Private Sub tbTitle_Change() + Call UpdateGID +End Sub + +Private Sub btnOK_Click() + If tbTitle.Text = vbNullString Or tbFileName.Text = vbNullString Then + Call UserInteraction.ShowMessage(EM_FILENAME_EMPTY) + Exit Sub + End If + + If VBA.Len(tbFileName.Text) + Len(AccessDatabase.docsLocation_) > 250 Then + Call UserInteraction.ShowMessage(EM_FILENAME_TOO_LONG) + Exit Sub + End If + + isCancelled_ = False + Call Me.Hide +End Sub + +Private Sub btnCancel_Click() + isCancelled_ = True + Call Me.Hide +End Sub + +Private Sub tbStatus_Change() + Dim sStatus$: sStatus = tbStatus.Text + If Not IsNumeric(sStatus) Then _ + Exit Sub + Dim val&: val = CLng(sStatus) + If val < 1 Or val > cbDocStatus.ListCount Then _ + Exit Sub + cbDocStatus.ListIndex = val - 1 +End Sub + +Private Sub tbType_Change() + Dim sType$: sType = tbType.Text + If Not IsNumeric(sType) Then _ + Exit Sub + + Dim val&: val = CLng(sType) + If val < 1 Or val > cbDocType.ListCount Then _ + Exit Sub + + cbDocType.ListIndex = val - 1 +End Sub + +Private Sub cbDocStatus_Change() + tbStatus.Value = cbDocStatus.ListIndex + 1 +End Sub + +Private Sub cbDocType_Change() + tbType.Value = cbDocType.ListIndex + 1 +End Sub + +' ================= +Private Function UpdateGID() + If Not isNewID_ Then _ + Exit Function + + tbGID.Text = AccessDatabase.GenerateID(tbTitle.Text) +End Function + +Private Function SystemIndexFor(pType As TLinkSystem) As Long + Select Case pType + Case PT_MOBILE: SystemIndexFor = 0 + Case PT_LOCAL: SystemIndexFor = 1 + Case PT_INTERNET: SystemIndexFor = 2 + End Select +End Function + +Private Function SystemTypeFor(nIndex&) As TLinkSystem + Select Case nIndex + Case 0: SystemTypeFor = PT_MOBILE + Case 1: SystemTypeFor = PT_LOCAL + Case 2: SystemTypeFor = PT_INTERNET + End Select +End Function + diff --git a/src/addin/NewDocumentDlg.frx b/src/addin/NewDocumentDlg.frx new file mode 100644 index 0000000..d2d6823 Binary files /dev/null and b/src/addin/NewDocumentDlg.frx differ diff --git a/src/addin/NewLinkDlg.frm b/src/addin/NewLinkDlg.frm new file mode 100644 index 0000000..620fb6d --- /dev/null +++ b/src/addin/NewLinkDlg.frm @@ -0,0 +1,121 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} NewLinkDlg + Caption = " " + ClientHeight = 4260 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 7260 + OleObjectBlob = "NewLinkDlg.frx":0000 + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "NewLinkDlg" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Explicit + +Public isCancelled_ As Boolean + +Private database_ As InfoDatabase +Private source_ As InfoDocument +Private bms_ As Word.Bookmarks + +Private Sub UserForm_Initialize() + isCancelled_ = True + Call PositionInMiddle(Me) +End Sub + +Public Function Init(iSource As InfoDocument, theDB As InfoDatabase, existingBMs As Word.Bookmarks) + isCancelled_ = True + + Set database_ = theDB + Set source_ = iSource + Set bms_ = existingBMs + + Call InitSourceBookmarks +End Function + +Public Function GetLink() As ItemLink + Set GetLink = New ItemLink + With GetLink + .sourceID_ = source_.gid_ + .sourceSub_ = cbSourceBookmark.Text + .destID_ = CLng(tbDocumentID.Text) + .destSub_ = tbSubTo.Text + .type_ = GetLinkType + End With +End Function + +' ============ +Private Sub btnValidateGid_Click() + If Not IsNumeric(tbDocumentID.Value) Then + Call UserInteraction.ShowMessage(EM_ID_INVALID_FORMAT) + Exit Sub + End If + Dim gid&: gid = tbDocumentID.Value + + If Not database_.Contains(gid) Then + tbTitle.Text = " " + Exit Sub + End If + + Dim docIter As IteratorLaw: Set docIter = database_.Data(gid) + If docIter.Status = T_LAWS_IGNORE Then + tbTitle.Text = " " + Exit Sub + End If + + tbTitle.Text = docIter.Title +End Sub + +Private Sub btnCancel_Click() + isCancelled_ = True + Call Me.Hide +End Sub + +Private Sub btnOK_Click() + If Not ValidateBookmark Then + Call UserInteraction.ShowMessage(EM_BOOKMARK_NOT_AVAILABLE) + Exit Sub + End If + + isCancelled_ = False + Call Me.Hide +End Sub + +' ============ +Private Function GetLinkType() As TLinkType + If optLevel0.Value = True Then + GetLinkType = T_LINK_DEFAULT + Exit Function + End If + If optLevel1.Value = True Then + GetLinkType = T_LINK_ASPECT + Exit Function + End If + If optLevel2.Value = True Then + GetLinkType = T_LINK_FOUNDATION + Exit Function + End If + If optLevel3.Value = True Then + GetLinkType = T_LINK_DEFINITION + Exit Function + End If +End Function + +Private Function InitSourceBookmarks() + Call cbSourceBookmark.Clear + Dim n& + For n = 1 To bms_.Count + Call cbSourceBookmark.AddItem(bms_.Item(n).Name) + Next n + If bms_.Count > 0 Then _ + cbSourceBookmark.Value = bms_.Item(1).Name +End Function + +Private Function ValidateBookmark() As Boolean + Dim sSub$: sSub = cbSourceBookmark.Text + ValidateBookmark = Not source_.doc_.Bookmarks.Exists(sSub) Or bms_.Exists(sSub) +End Function + diff --git a/src/addin/NewLinkDlg.frx b/src/addin/NewLinkDlg.frx new file mode 100644 index 0000000..cd2bd4c Binary files /dev/null and b/src/addin/NewLinkDlg.frx differ diff --git a/src/addin/z_UIMessages.bas b/src/addin/z_UIMessages.bas new file mode 100644 index 0000000..f7845fe --- /dev/null +++ b/src/addin/z_UIMessages.bas @@ -0,0 +1,194 @@ +Attribute VB_Name = "z_UIMessages" +Option Private Module +Option Explicit + +Public Enum MsgCode + MSG_OK = 0 + + EM_SYNC_DOC = ERR_SYNC_DOC + EM_SYNC_DB = ERR_SYNC_DB + EM_SYNC_LINK_ID = ERR_SYNC_LINK_ID + EM_LINKS_MISSING = ERR_LINKS_MISSING + EM_INVALID_LINK_NUMBER = ERR_INVALID_LINK_NUMBER + EM_LINK_NO_FILE = ERR_LINK_NO_FILE + EM_BOOKMARK_INVALID = ERR_BOOKMARK_INVALID + EM_LINK_SELF = ERR_LINK_SELF + EM_ADD_LINK_DB_FAILED = ERR_ADD_LINK_DB_FAILED + EM_ADD_LINK_DOC_FAILED = ERR_ADD_LINK_DOC_FAILED + + EM_DOC_NOT_ADDED = vbObjectError + 1 + EM_DOC_FILE_EXISTS + EM_TITLELINK_INVALID + EM_SELECTION_INVALID + EM_FILENAME_TAKEN + EM_LINKS_NOT_ZERO + EM_PARAGRAPH_MULTIPLE + EM_LINK_COUNT + EM_LINK_SINGLE + EM_LINK_INVALID + EM_DOC_NO_LINKS + EM_HELP_FILE_INVALID + EM_REMOVE_FIRST_LINK + EM_NO_BOOKMARKS + EM_FILE_ALREADY_ADDED + EM_BOOKMARK_NOT_AVAILABLE + EM_NO_VALID_LINKS + EM_FILENAME_EMPTY + EM_FILENAME_TOO_LONG + EM_HAS_NO_LINKS + EM_ID_INVALID_FORMAT + EM_SELECTION_NOT_IN_MAIN + + IM_SCAN_MODE + IM_IGNORE_MODE + IM_LINKS_TODO + IM_LINKS_DONE + IM_DOC_OUTER + IM_LINKS_ADDED + IM_DOC_IGNORED + IM_DOC_LINKS_DONE + IM_HYPERLINKS_DONE + IM_QUERY_LINK + IM_DOC_EXPRESS_ADD + IM_REMOVE_LINK_OK + + QM_ADD_TITLELINK + QM_OPEN_GARANT + QM_DELETE_BEFORE_ADD + QM_DELETE_BEFORE_ADD_DUMMY + QM_RELOAD_ON_UPDATE + QM_RELOAD_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) + + Select Case Err.Number + Case ERR_LINK_NO_FILE: Call UserInteraction.ShowMessage(Err.Number, Err.Source) + Case ERR_BOOKMARK_INVALID: Call UserInteraction.ShowMessage(Err.Number, Err.Source) + Case ERR_INVALID_LINK_NUMBER: Call UserInteraction.ShowMessage(Err.Number) + Case ERR_SYNC_DB: Call UserInteraction.ShowMessage(Err.Number) + Case ERR_SYNC_DOC: Call UserInteraction.ShowMessage(Err.Number) + Case ERR_LINK_SELF: Call UserInteraction.ShowMessage(Err.Number) + Case ERR_LINKS_MISSING: Call UserInteraction.ShowMessage(Err.Number) + Case ERR_ADD_LINK_DB_FAILED: Call UserInteraction.ShowMessage(Err.Number) + Case ERR_ADD_LINK_DOC_FAILED: Call UserInteraction.ShowMessage(Err.Number) + Case ERR_SYNC_LINK_ID: Call UserInteraction.ShowMessage(Err.Number, Err.Description) + + Case Else: Call UserInteraction.ShowMessage(Err.Number) + End Select + + Call Err.Clear + On Error GoTo 0 +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_DOC_NOT_ADDED: Call MsgBox(" ", vbExclamation) + Case EM_DOC_FILE_EXISTS: Call MsgBox(Fmt("! ID {1} : {2}", unwrapped), vbExclamation, " ") + Case EM_SYNC_DOC: Call MsgBox("! !" & vbNewLine & " ", vbCritical) + Case EM_SYNC_DB: Call MsgBox("! !" & vbNewLine & " ", vbCritical) + Case EM_TITLELINK_INVALID: Call MsgBox(" !", vbExclamation, " ") + Case EM_LINK_SELF: Call MsgBox(" ", vbExclamation) + Case EM_LINKS_MISSING: Call MsgBox("! . ", vbExclamation) + Case EM_SYNC_LINK_ID: Call MsgBox(Fmt("! ! {1}" & vbNewLine & " ", unwrapped), vbCritical) + + Case EM_SELECTION_INVALID: Call MsgBox(" . ", vbExclamation) + Case EM_SELECTION_NOT_IN_MAIN: Call MsgBox(" . , ", vbExclamation) + Case EM_LINK_NO_FILE: Call MsgBox(Fmt(", " & vbNewLine & "ID: {1}", unwrapped), vbExclamation) + Case EM_BOOKMARK_INVALID: Call MsgBox(Fmt(" : {1}", unwrapped), vbExclamation) + Case EM_FILENAME_TAKEN: Call MsgBox(" !", vbExclamation) + Case EM_LINKS_NOT_ZERO: Call MsgBox(" ", vbExclamation) + Case EM_PARAGRAPH_MULTIPLE: Call MsgBox(" ", vbExclamation) + Case EM_LINK_COUNT: Call MsgBox(" ", vbExclamation) + Case EM_LINK_SINGLE: Call MsgBox(" ", vbExclamation) + Case EM_LINK_INVALID: Call MsgBox(" ", vbExclamation) + Case EM_DOC_NO_LINKS: Call MsgBox(" , ", vbExclamation) + Case EM_HELP_FILE_INVALID: Call MsgBox(Fmt(" : {1}", unwrapped), vbExclamation) + Case EM_REMOVE_FIRST_LINK: Call MsgBox(" !", vbExclamation) + Case EM_NO_BOOKMARKS: Call MsgBox(" ", vbExclamation) + Case EM_FILE_ALREADY_ADDED: Call MsgBox(" . """" ", vbExclamation) + Case EM_INVALID_LINK_NUMBER: Call MsgBox(" . ", vbExclamation) + Case EM_ADD_LINK_DB_FAILED: Call MsgBox(" ", vbExclamation) + Case EM_ADD_LINK_DOC_FAILED: Call MsgBox(" ", vbExclamation) + Case EM_NO_VALID_LINKS: Call MsgBox(" !", vbExclamation) + Case EM_FILENAME_EMPTY: Call MsgBox(" !", vbExclamation) + Case EM_FILENAME_TOO_LONG: Call MsgBox(" 255 !", vbExclamation) + Case EM_HAS_NO_LINKS: Call MsgBox(" . ", vbExclamation) + Case EM_ID_INVALID_FORMAT: Call MsgBox(" ", vbExclamation) + Case EM_BOOKMARK_NOT_AVAILABLE: + Call MsgBox(" !" & vbNewLine & _ + " ", vbExclamation) + + ' ================= ====================== + Case IM_SCAN_MODE: Call MsgBox(" , ", vbInformation) + Case IM_IGNORE_MODE: Call MsgBox(" , ", vbInformation) + Case IM_LINKS_TODO: Call MsgBox(Fmt(" , : {1}" & vbNewLine & " : {2}", unwrapped), vbInformation) + Case IM_LINKS_DONE: Call MsgBox(Fmt(" " & vbNewLine & " : {1}", unwrapped), vbInformation) + Case IM_DOC_OUTER: Call MsgBox(" . ", vbInformation) + Case IM_LINKS_ADDED: Call MsgBox(Fmt(" ." & vbNewLine & " : {1}", unwrapped), vbInformation) + Case IM_DOC_IGNORED: Call MsgBox(Fmt(" : {1}", unwrapped), vbInformation) + Case IM_DOC_LINKS_DONE: Call MsgBox(" " & vbNewLine & " ( HT03_UpdateMarkup)!", vbInformation) + Case IM_HYPERLINKS_DONE: Call MsgBox(" ", vbInformation) + Case IM_QUERY_LINK: Call MsgBox(Fmt(" : {1}", unwrapped), vbInformation) + Case IM_DOC_EXPRESS_ADD: Call MsgBox(Fmt(" : {1}", unwrapped), vbInformation) + Case IM_REMOVE_LINK_OK: 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 As Long: answer = vbNo + Select Case theCode + Case QM_ADD_TITLELINK + answer = MsgBox(Fmt("! " & vbNewLine & _ + " ID: {1}" & vbNewLine & _ + " . ?", unwrapped), vbYesNo + vbQuestion) + Case QM_OPEN_GARANT + answer = MsgBox(Fmt(" , " & _ + " " & _ + " " & vbNewLine & _ + "ID : {1}" & vbNewLine & _ + " ?", unwrapped), vbYesNo + vbQuestion) + Case QM_DELETE_BEFORE_ADD + answer = MsgBox(Fmt(" ID !" & vbNewLine & "ID: {1}" & vbNewLine & _ + " ?" & vbNewLine & _ + "!! !!", unwrapped), vbYesNo + vbExclamation) + Case QM_DELETE_BEFORE_ADD_DUMMY + answer = MsgBox(Fmt(" ID !" & vbNewLine & "ID: {1}" & vbNewLine & _ + " ?" & vbNewLine & vbNewLine & _ + " , ", unwrapped), vbYesNo + vbExclamation) + Case QM_RELOAD_ON_UPDATE + answer = MsgBox(Fmt(" {1} " & vbNewLine & _ + " ?", unwrapped), vbYesNo + vbExclamation) + Case QM_RELOAD_CONFIRM: answer = MsgBox(Fmt(" . ?", unwrapped), vbYesNo + vbExclamation) + + Case Else + Call MsgBox(" ", vbCritical) + End Select + UIAskQuestion = answer = vbYes +End Function diff --git a/src/addin/z_UIRibbon.bas b/src/addin/z_UIRibbon.bas new file mode 100644 index 0000000..a20447e --- /dev/null +++ b/src/addin/z_UIRibbon.bas @@ -0,0 +1,25 @@ +Attribute VB_Name = "z_UIRibbon" +Option Explicit + +Sub HT03_OnRibbonBtn(iControl As IRibbonControl) + Select Case iControl.ID + Case "HT03_NextLink": Call HT03_NextLink + Case "HT03_ChangeLType": Call HT03_ChangeLType + Case "HT03_ChangeStatus": Call HT03_ChangeStatus + Case "HT03_QueryLink": Call HT03_QueryLink + Case "HT03_ExpressLinks": Call HT03_ExpressLinks + Case "HT03_ExpressDocuments": Call HT03_ExpressDocuments + Case "HT03_RejectDocument": Call HT03_RejectDocument + Case "HT03_UpdateMarkup": Call HT03_UpdateMarkup + Case "HT03_ModifyDoc": Call HT03_EditDocument + Case "HT03_OpenRegistry": Call HT03_Registry + Case "HT03_ReloadIndex": Call HT03_ReloadIndex + Case "HT03_AddDoc": Call HT03_AddDoc + Case "HT03_AddLink": Call HT03_AddLink + Case "HT03_AddNew": Call HT03_AddNew + Case "HT03_Help": Call HT03_Help + Case "HT03_FollowLink": Call HT03_FollowLink + Case "HT03_RemoveLink": Call HT03_RemoveLink + Case "HT03_ReloadLinks": Call HT03_ReloadLinks + End Select +End Sub diff --git a/src/common/ActiveStateExporter.cls b/src/common/ActiveStateExporter.cls new file mode 100644 index 0000000..d7741db --- /dev/null +++ b/src/common/ActiveStateExporter.cls @@ -0,0 +1,92 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ActiveStateExporter" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ===== Export active laws and links ====== +Option Explicit + +Private out_ As Excel.Workbook +Private lawOut_ As Excel.Worksheet +Private linkOut_ As Excel.Worksheet +Private db_ As InfoDatabase + +Public Function Init(outWB As Excel.Workbook, theData As InfoDatabase) + Set out_ = outWB + Set db_ = theData + + Set lawOut_ = out_.Sheets(1) + Set linkOut_ = out_.Sheets.Add(After:=lawOut_) + + Call CreateHeaders +End Function + +Public Function ExportLaws() As Scripting.Dictionary + Dim lawIDs As New Scripting.Dictionary + Dim iLaw As IteratorLaw: Set iLaw = db_.Laws + Dim nLaw&: nLaw = 1 + Dim nRow&: nRow = HT03_DEFAULT_FIRST_LINE + Do While Not iLaw.IsDone + If iLaw.IsActive Then + lawOut_.Cells(nRow, S_OD_ID) = nLaw + lawOut_.Cells(nRow, S_OD_LEVEL) = DefaultLawLevelFor(iLaw.DType) + lawOut_.Cells(nRow, S_OD_TITLE) = iLaw.Title + lawOut_.Cells(nRow, S_OD_TYPE) = iLaw.DType + lawOut_.Cells(nRow, S_OD_GID) = iLaw.ID + Call lawIDs.Add(iLaw.ID, nLaw) + nLaw = nLaw + 1 + nRow = nRow + 1 + End If + Call iLaw.Increment + Call CSE_ProgressBar.IncrementA + Call CSE_ProgressBar.IncrementB + Loop + + Set ExportLaws = lawIDs +End Function + +Public Function ExportLinks(lawIDs As Scripting.Dictionary) + Dim nRow&: nRow = HT03_DEFAULT_FIRST_LINE + Dim iLink As IteratorLinkAll: Set iLink = db_.Links + Do While Not iLink.IsDone + If Not iLink.IsActive Then _ + GoTo NEXT_LINK + If iLink.SourceID = iLink.DestinationID Then _ + GoTo NEXT_LINK + If Not lawIDs.Exists(iLink.SourceID) Or Not lawIDs.Exists(iLink.DestinationID) Then _ + GoTo NEXT_LINK + + linkOut_.Cells(nRow, S_OL_SOURCE) = lawIDs(iLink.SourceID) + linkOut_.Cells(nRow, S_OL_TARGET) = lawIDs(iLink.DestinationID) + linkOut_.Cells(nRow, S_OL_TYPE) = iLink.LType + nRow = nRow + 1 + +NEXT_LINK: + Call iLink.Increment + Call CSE_ProgressBar.IncrementA + Call CSE_ProgressBar.IncrementB + Loop + Call linkOut_.Range("A:E").RemoveDuplicates(Columns:=Array(1, 2, 3), Header:=xlYes) +End Function + +' ============== +Private Function CreateHeaders() + With lawOut_ + .Name = "" + .Cells(1, S_OD_ID) = "ID" + .Cells(1, S_OD_LEVEL) = "" + .Cells(1, S_OD_TITLE) = "" + .Cells(1, S_OD_TYPE) = "" + .Cells(1, S_OD_GID) = "ID " + End With + With linkOut_ + .Name = "" + .Cells(1, S_OL_SOURCE) = "Source" + .Cells(1, S_OL_TARGET) = "Target" + .Cells(1, S_OL_TYPE) = " " + End With +End Function diff --git a/src/common/DatabaseImpl.bas b/src/common/DatabaseImpl.bas new file mode 100644 index 0000000..c704a96 --- /dev/null +++ b/src/common/DatabaseImpl.bas @@ -0,0 +1,285 @@ +Attribute VB_Name = "DatabaseImpl" +' ======== ===================== +Option Private Module +Option Explicit + +Public Const HT03_DBNAME = "! .xlsm" ' + +Public Const HT03_DOC_EXTENSION = ".docx" + +Public Const HT03_DEFAULT_FIRST_LINE = 2 ' + +Public Const HT03_INVALID_ROW = -1 +Public Const HT03_INVALID_GID = -1 + +Public Const HT03_SHT_DOCS = "" +Public Const HT03_SHT_LINKS = "" +Public Const HT03_SHT_STATS = "" +Public Const HT03_SHT_INFO = "" + +Public Const HT03_FILE_NOT_LOADED = "! " +Public Const HT03_TITLE_NOT_LOADED = "! " + +Public Const HT03_DEFAULT_WORKDIR = "" + +Public Const HT03_CELL_HASH = "c_Hash" +Public Const HT03_CELL_FOLDER = "c_Folder" + +Public Const HT03_DUMMY_DOCUMENT_DISCLAIMER = _ + " . " & _ + " . " & _ + " , , ." + +' Errors raised by DB +Public Enum DBErrors + ERR_SYNC_DB = vbObjectError + 1000 + ERR_SYNC_DOC + ERR_LINKS_MISSING + ERR_SYNC_LINK_ID + ERR_INVALID_LINK_NUMBER + ERR_LINK_NO_FILE + ERR_BOOKMARK_INVALID + ERR_LINK_SELF + ERR_ADD_LINK_DB_FAILED + ERR_ADD_LINK_DOC_FAILED +End Enum + +'# _D_ +Public Enum LawStruct + [_First] = 1 + + S_D_GARANT_ID = 1 ' ID + S_D_STATUS = 2 ' (. ) + S_D_TYPE = 3 ' + S_D_FILENAME = 4 ' + S_D_TITLE = 5 ' + S_D_TYPE_TXT = 6 ' + S_D_CREATOR = 7 ' + S_D_DATE = 8 ' + S_D_NUMBER = 9 ' + S_D_HEADER = 10 ' + S_D_ATTACH = 11 ' + S_D_TIME_SCOPED = 12 ' + S_D_IS_DUMMY = 13 ' + + S_D_LINKBASE = 14 ' + + [_Last] = 14 +End Enum + +'# _L_ +Public Enum LinkStruct + [_First] = 1 + + S_L_FROM_ID = 1 ' ID , + S_L_FROM_SUB = 2 ' ID + S_L_TO_ID = 3 ' ID , + S_L_TO_SUB = 4 ' ID + S_L_TYPE = 5 ' (. ) + S_L_STATUS = 6 ' (. ) + + [_Last] = 6 +End Enum + +'# _CD_ +Public Enum LawCacheStruct + [_First] = 1 + + S_CD_ID = 1 + S_CD_TYPE = 2 + S_CD_STATUS = 3 + S_CD_LINKBASE = 4 + + [_Last] = 4 +End Enum + +'# _CL_ +Public Enum LinkCacheStruct + [_First] = 1 + + S_CL_DESTINATION_ID = 1 + S_CL_TYPE = 2 + S_CL_STATUS = 3 + + [_Last] = 3 +End Enum + +'# _TL_ +Public Enum LinkTransferStruct + [_First] = 1 + + S_TL_DESTINATION_ID = 1 + S_TL_DESTINATION_SUB = 2 + S_TL_SOURCE_SUB = 3 + + [_Last] = 3 +End Enum + +' _OD_ Output structure for Laws +Public Enum OutputLawsStruct + S_OD_ID = 1 + S_OD_LEVEL = 2 + S_OD_TITLE = 3 + S_OD_TYPE = 4 + S_OD_GID = 5 +End Enum + +' _OL_ Output laws structure for Links +Public Enum OutputLinksStruct + S_OL_SOURCE = 1 + S_OL_TARGET = 2 + S_OL_TYPE = 3 +End Enum + +Public Function ParseHyperlink(target As Word.Hyperlink) As ItemHyperlink + Dim iLink As New ItemHyperlink + If Not iLink.FromAddress(target.Address) Then _ + Exit Function + Set ParseHyperlink = iLink +End Function + +Public Function ParseDocument(theDoc As Word.Document) As InfoDocument + Dim iDoc As New InfoDocument + If Not iDoc.Init(theDoc) Then _ + Exit Function + Set ParseDocument = iDoc +End Function + +Public Function ParseLawTitle(sTitle$) As ItemLaw + Dim titleTxt$: titleTxt = SubstituteWhitespace(sTitle) + Dim theParser As ParserNPA: Set theParser = GetParserLawTitle + If Not theParser.Parse(titleTxt) Then _ + Exit Function + + Dim dateParser As ParserDate: Set dateParser = GetParserDate + Debug.Assert dateParser.Test(theParser.data_.date_) + Call dateParser.Parse(theParser.data_.date_) + + Set ParseLawTitle = New ItemLaw + With ParseLawTitle + .title_ = ApplyCommonAbbreviations(titleTxt) + .typeTxt_ = theParser.data_.docType_ + .creator_ = theParser.data_.creator_ + .date_ = dateParser.AsDigitsString + .number_ = theParser.data_.number_ + .header_ = theParser.data_.title_ + .attach_ = theParser.data_.titleDoc_ + .isScoped_ = theParser.data_.isTimeBound_ + + .type_ = InferTypeFrom(.typeTxt_, .creator_) + If .creator_ = vbNullString Then _ + .creator_ = InferCreatorFrom(.type_) + End With +End Function + +Public Function GetDatabaseHash(target As Excel.Workbook) As String + Dim hashRng As Excel.Range: Set hashRng = target.Names(HT03_CELL_HASH).RefersToRange + Call hashRng.Calculate + GetDatabaseHash = hashRng +End Function + +Public Function GetDocumentsLocation(target As Excel.Workbook) As String + Dim iPath As New API_Path: Call iPath.FromString(target.Names(HT03_CELL_FOLDER).RefersToRange) + Call iPath.ToServer(target.Path) + GetDocumentsLocation = iPath.Text + If GetDocumentsLocation = vbNullString Then _ + GetDocumentsLocation = target.Path +End Function + +Public Function GetParserLawTitle() As ParserNPA + Static s_Parser As ParserNPA + If s_Parser Is Nothing Then _ + Set s_Parser = New ParserNPA + Set GetParserLawTitle = s_Parser +End Function + +Public Function GetParserDate() As ParserDate + Static s_Parser As ParserDate + If s_Parser Is Nothing Then _ + Set s_Parser = New ParserDate + Set GetParserDate = s_Parser +End Function + +Public Function InferTypeFrom(sDocType$, sCreator$) As TLawType + InferTypeFrom = T_LAW_01_UNKNOWN + + If sDocType Like "[]*" Then + InferTypeFrom = T_LAW_03_CONSTITUTION + ElseIf sDocType Like "*[]*" Then + InferTypeFrom = IIf(sDocType Like "*[]*", T_LAW_04_FEDERAL_CONST, T_LAW_07_FEDERALLAW) + Exit Function + ElseIf sDocType Like "*[]*" Then + InferTypeFrom = T_LAW_05_CODEX + Exit Function + End If + + If sCreator = vbNullString Then + Exit Function + ElseIf sCreator Like "*[]*" Then + InferTypeFrom = T_LAW_06_PRESIDENT + Exit Function + End If + + Dim sFirstCreator$: sFirstCreator = sCreator + If InStr(sFirstCreator, " ") <> 0 Then _ + sFirstCreator = Left(sCreator, InStr(sFirstCreator, " ")) + If InStr(sFirstCreator, ", ") <> 0 Then _ + sFirstCreator = Left(sCreator, InStr(sFirstCreator, ", ")) + + If sFirstCreator Like "*[]*" Or sFirstCreator Like "*[]*" Then + InferTypeFrom = T_LAW_10_PROSECUTOR + ElseIf sFirstCreator Like "*[]*" Then + InferTypeFrom = T_LAW_08_GOVERNMENT + ElseIf sFirstCreator Like "* []*" Then + InferTypeFrom = T_LAW_09_JUSTICE + ElseIf sFirstCreator Like "*[]*" Or sFirstCreator Like "*" Then + InferTypeFrom = T_LAW_11_MINISTRY + ElseIf sFirstCreator Like "*" Then + InferTypeFrom = T_LAW_11_MINISTRY + ElseIf sFirstCreator Like "**" Or sFirstCreator Like "**" Or sFirstCreator Like "**" Then + InferTypeFrom = T_LAW_12_AGENCY + ElseIf sFirstCreator Like "*" Or sFirstCreator Like "*" Then + InferTypeFrom = T_LAW_12_AGENCY + End If +End Function + +Public Function InferCreatorFrom(sType As TLawType) As String + Select Case (sType) + Case T_LAW_03_CONSTITUTION: InferCreatorFrom = " " + Case T_LAW_04_FEDERAL_CONST: InferCreatorFrom = " " + Case T_LAW_05_CODEX: InferCreatorFrom = " " + Case T_LAW_07_FEDERALLAW: InferCreatorFrom = " " + Case T_LAW_09_JUSTICE: InferCreatorFrom = " " + Case T_LAW_10_PROSECUTOR: InferCreatorFrom = " " + End Select +End Function + +Public Function DefaultLawLevelFor(aType As TLawType) As Long + Select Case aType + Case 0: DefaultLawLevelFor = 0 + Case 1: DefaultLawLevelFor = 7 + Case 2 To 3: DefaultLawLevelFor = 1 + Case 4: DefaultLawLevelFor = 2 + Case 5 To 7: DefaultLawLevelFor = 3 + Case 8 To 10: DefaultLawLevelFor = 4 + Case 11: DefaultLawLevelFor = 5 + Case 12: DefaultLawLevelFor = 6 + End Select +End Function + +Public Function AddDummyDocument(props As ItemLaw, sDocsPath$, Optional linkSys As TLinkSystem = DEFAULT_LINK_SYSTEM) + Dim wordWrap As New API_WordWrapper + Dim newDoc As Word.Document: Set newDoc = wordWrap.NewDocument + + Call newDoc.Paragraphs.Add + newDoc.Paragraphs.First.Range = props.title_ + Dim lnkRange As Word.Range: Set lnkRange = newDoc.Paragraphs.First.Range + Dim newLink As New ItemHyperlink: Call newLink.Init(linkSys, props.gid_, "sub_0") + Call lnkRange.Hyperlinks.Add(lnkRange, newLink.ToAddress) + + Call newDoc.Paragraphs.Add + newDoc.Paragraphs.Last.Range = HT03_DUMMY_DOCUMENT_DISCLAIMER + + Call newDoc.SaveAs(sDocsPath & "\" & props.fileName_, FileFormat:=wdFormatDocumentDefault) + Call wordWrap.ReleaseDocument +End Function diff --git a/src/common/DatabaseModel.bas b/src/common/DatabaseModel.bas new file mode 100644 index 0000000..bc78d32 --- /dev/null +++ b/src/common/DatabaseModel.bas @@ -0,0 +1,60 @@ +Attribute VB_Name = "DatabaseModel" +' ======== ===================== +Option Private Module +Option Explicit + +'# +Public Enum TLawType + [_First] = 0 + + T_LAW_DEFAULT = 0 ' + T_LAW_01_UNKNOWN = 1 ' + T_LAW_02_INTERNATIONAL = 2 ' + T_LAW_03_CONSTITUTION = 3 ' + T_LAW_04_FEDERAL_CONST = 4 ' + T_LAW_05_CODEX = 5 ' + T_LAW_06_PRESIDENT = 6 ' + T_LAW_07_FEDERALLAW = 7 ' + T_LAW_08_GOVERNMENT = 8 ' + T_LAW_09_JUSTICE = 9 ' + T_LAW_10_PROSECUTOR = 10 ' + T_LAW_11_MINISTRY = 11 ' + T_LAW_12_AGENCY = 12 ' / / + + [_Last] = 12 +End Enum + +'# +Public Enum TLawStatus + [_First] = 1 + + T_LAWS_NOTDEFINED = 0 ' 0 - () + T_LAWS_FULL = 1 ' 1 - + T_LAWS_FRINGE = 2 ' 2 - + T_LAWS_OUTER = 3 ' 3 - + T_LAWS_IGNORE = 4 ' 4 - + + [_Last] = 4 +End Enum + +'# +Public Enum TLinkType + [_First] = 0 + + T_LINK_DEFAULT = 0 ' 0 - ( ) + T_LINK_ASPECT = 1 ' 1 - + T_LINK_FOUNDATION = 2 ' 2 - + T_LINK_DEFINITION = 3 ' 3 - + + [_Last] = 3 +End Enum + +'# +Public Enum TLinkStatus + [_First] = 0 + + T_LINKS_IGNORE = 0 ' 0 - + T_LINKS_ADD = 1 ' 1 - ( ) + + [_Last] = 1 +End Enum diff --git a/src/common/DocumentProcessor.bas b/src/common/DocumentProcessor.bas new file mode 100644 index 0000000..18b8d4e --- /dev/null +++ b/src/common/DocumentProcessor.bas @@ -0,0 +1,192 @@ +Attribute VB_Name = "DocumentProcessor" +'===================================== +'==== ==== +'===================================== +Option Explicit + +Public Const Style0A = "_01 " + +Public Const Style10 = "_02 " +Public Const Style11 = "_03 " +Public Const Style12 = "_04 " +Public Const Style13 = "_05 " + +Public Const Style20 = "_02 " +Public Const Style21 = "_03 " +Public Const Style22 = "_04 " +Public Const Style23 = "_05 " + +Public Const Style30 = "_02 " +Public Const Style31 = "_03 " +Public Const Style32 = "_04 " +Public Const Style33 = "_05 " + +Public Const Style4A = "_06 " + +Public Const STYLE_KEY_PREFIX = "Style" +Public Const STYLE_KEY_FAIL_POSTFIX = "A" + +Public Enum TLinkSystem + PT_INVALID = -1 + PT_LOCAL = 1 + PT_MOBILE = 2 + PT_INTERNET = 3 +End Enum + +Public Const DEFAULT_LINK_SYSTEM = TLinkSystem.PT_INTERNET + +Public Function GetAllLinkStyles() As Collection + Static s_Styles As Collection + If Not s_Styles Is Nothing Then + Set GetAllLinkStyles = s_Styles + Exit Function + End If + + Set s_Styles = New Collection + With s_Styles + Call .Add(Style0A, "Style0A") + + Call .Add(Style10, "Style10") + Call .Add(Style11, "Style11") + Call .Add(Style12, "Style12") + Call .Add(Style13, "Style13") + + Call .Add(Style20, "Style20") + Call .Add(Style21, "Style21") + Call .Add(Style22, "Style22") + Call .Add(Style23, "Style23") + + Call .Add(Style30, "Style30") + Call .Add(Style31, "Style31") + Call .Add(Style32, "Style32") + Call .Add(Style33, "Style33") + + Call .Add(Style4A, "Style4A") + End With + Set GetAllLinkStyles = s_Styles +End Function + +Public Function IsHyperlinkValid(target As Word.Hyperlink) As Boolean + IsHyperlinkValid = Not ParseHyperlink(target) Is Nothing +End Function + +Public Function GetFirstValidHyperlinkIn(target As Word.Range) As Word.Hyperlink + Dim docHLink As Word.Hyperlink + For Each docHLink In target.Hyperlinks + If IsHyperlinkValid(docHLink) Then + Set GetFirstValidHyperlinkIn = docHLink + Exit Function + End If + Next docHLink +End Function + +Public Function ScanLawIDs(target As Word.Range) As Scripting.Dictionary + Dim docs As New Scripting.Dictionary + + Dim docHLink As Word.Hyperlink + Dim iLink As ItemHyperlink + For Each docHLink In target.Hyperlinks + Set iLink = ParseHyperlink(docHLink) + If Not iLink Is Nothing Then + Dim targetID&: targetID = iLink.DocumentID + If Not docs.Exists(targetID) Then _ + Call docs.Add(targetID, 0) + End If + Next docHLink + + Set ScanLawIDs = docs +End Function + +Public Function PrepareDocumentText(doc As Word.Document, iMods As ItemDocumentModification) + If iMods.deleteRevision_ Then + On Error Resume Next + With doc.Content.Find + .ClearFormatting + .Format = True + .Text = vbNullString + .Replacement.Text = vbNullString + .wrap = wdFindContinue + .Style = " " + .Execute Replace:=wdReplaceAll + + On Error Resume Next + .ClearFormatting + .Format = False + .Text = " :?" + .MatchWildcards = True + .Replacement.Text = vbNullString + .wrap = wdFindContinue + .Execute Replace:=wdReplaceAll + + On Error Resume Next + .ClearFormatting + .Format = True + .Text = vbNullString + .Replacement.Text = vbNullString + .wrap = wdFindContinue + .Style = " " + .Execute Replace:=wdReplaceAll + On Error GoTo 0 + + End With + End If + + If iMods.deleteComment_ Then + Call DeleteLinksByText(doc, "[]") + Call DeleteLinksByText(doc, "[] ") + Call DeleteLinksByText(doc, "[][] ") + End If + + If iMods.deleteImages_ Then + Dim iShp As Word.InlineShape + Do While doc.InlineShapes.Count > 0 + Set iShp = doc.InlineShapes.Item(1) + Dim pasteRange As Word.Range: Set pasteRange = iShp.Range.Duplicate + Call pasteRange.Collapse(wdCollapseStart) + Call iShp.Delete + pasteRange.Text = "[ ]" + pasteRange.Font.Bold = True + Loop + End If +End Function + +Public Function CreateBookmarkFor(target As Word.Range) As String + Dim bmCount&: bmCount = target.Document.Bookmarks.Count + Dim newName$: newName = "lnk_" & CStr(bmCount + 1) + Do While target.Document.Bookmarks.Exists(newName) + bmCount = bmCount + 1 + newName = "lnk_" & CStr(bmCount) + Loop + + Call target.Bookmarks.Add(newName) + CreateBookmarkFor = newName +End Function + +Public Function GetLinkStatusStyle(sSource As TLawStatus, sDestination As TLawStatus, nType As TLinkType) As String + Dim sStyle$: sStyle = STYLE_KEY_PREFIX + If sDestination = T_LAWS_IGNORE _ + Or sSource = T_LAWS_OUTER _ + Or (sSource = T_LAWS_FRINGE And sDestination = T_LAWS_NOTDEFINED) Then + sStyle = sStyle & CStr(T_LAWS_IGNORE) & STYLE_KEY_FAIL_POSTFIX + Else + sStyle = sStyle & CStr(sDestination) & IIf(sDestination = T_LAWS_NOTDEFINED, STYLE_KEY_FAIL_POSTFIX, CStr(nType)) + End If + + If InCollection(sStyle, GetAllLinkStyles) Then + GetLinkStatusStyle = GetAllLinkStyles.Item(sStyle) + Else + GetLinkStatusStyle = "" + End If +End Function + +' ======= +Private Function DeleteLinksByText(aDoc As Word.Document, sMask$) + Dim hLink As Word.Hyperlink + Dim i&: i = aDoc.Hyperlinks.Count + Do While i > 0 + Set hLink = aDoc.Hyperlinks(i) + If hLink.TextToDisplay Like sMask Then _ + hLink.Delete + i = i - 1 + Loop +End Function diff --git a/src/common/InfoDatabase.cls b/src/common/InfoDatabase.cls new file mode 100644 index 0000000..78d0e3d --- /dev/null +++ b/src/common/InfoDatabase.cls @@ -0,0 +1,668 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "InfoDatabase" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ========== Document database wrapper =============== +Option Explicit + +Private index_ As Scripting.Dictionary + +Private database_ As Excel.Workbook +Private docs_ As Excel.Worksheet +Private links_ As Excel.Worksheet + +Private hash_ As String +Private uiControl_ As API_XLWrapper + +Public docsLocation_ As String + +Private Sub Class_Terminate() + Set database_ = Nothing + Set docs_ = Nothing + Set links_ = Nothing + Set uiControl_ = Nothing +End Sub + +' Note: Unintialized object behavior is unspecified and most likely will cause system errors! +Public Function Init(dataSource As Excel.Workbook, Optional workDir$ = vbNullString) + Set database_ = dataSource + If workDir = vbNullString Then + docsLocation_ = database_.Path + Else + docsLocation_ = workDir + End If + + Set docs_ = database_.Sheets(HT03_SHT_DOCS) + Set links_ = database_.Sheets(HT03_SHT_LINKS) + Set uiControl_ = New API_XLWrapper + Call uiControl_.SetDocument(database_) + + Call Recreate +End Function + +' ========= Properties ============= +Public Property Get Loaded() As Boolean + Loaded = Not database_ Is Nothing +End Property + +Public Property Get NeedUpdate() As Boolean + Dim hashRng As Excel.Range: Set hashRng = database_.Names(HT03_CELL_HASH).RefersToRange + Call hashRng.Calculate + NeedUpdate = hash_ <> GetDatabaseHash(database_) +End Property + +Public Property Get Hash() As String + Hash = hash_ +End Property + +' Note: Approximate count. May be affected by Filters and Hidden rows +' Use iterators for precise acccess +Public Property Get Count() As Long + Count = docs_.Columns(S_D_GARANT_ID).Find(vbNullString, LookAt:=xlWhole).Row() - HT03_DEFAULT_FIRST_LINE +End Property + +' Note: Approximate count. May be affected by Filters and Hidden rows +' Use iterators for precise acccess +Public Property Get CountLinks() As Long + CountLinks = links_.Columns(S_L_FROM_ID).Find(vbNullString, LookAt:=xlWhole).Row() - HT03_DEFAULT_FIRST_LINE +End Property + +' ======== Data access ======= +Public Function Contains(gid&) As Boolean + Contains = index_.Exists(gid) +End Function + +Public Function HasLinksFor(gid&) As Boolean + If Contains(gid) Then + HasLinksFor = index_(gid).linkBase_ <> HT03_INVALID_ROW + Else + HasLinksFor = False + End If +End Function + +Public Function GetLawStatus(gid&) As TLawStatus + If Contains(gid) Then + GetLawStatus = Cache(gid).status_ + Else + GetLawStatus = T_LAWS_NOTDEFINED + End If +End Function + +Public Function GetLawInfo(gid&) As ItemLaw + If Not Contains(gid) Then _ + Exit Function + + Dim it As IteratorLaw: Set it = Data(gid) + If Not it.IsLoaded Then _ + Exit Function + + Dim iCache As ItemCachedLaw: Set iCache = Cache(gid) + Dim iLaw As New ItemLaw + With iLaw + .gid_ = iCache.id_ + .type_ = iCache.type_ + .status_ = iCache.status_ + .typeTxt_ = it.TypeText + .creator_ = it.Creator + .date_ = it.CreationDate + .number_ = it.Number + .header_ = it.Header + .attach_ = it.Attachment + .isScoped_ = it.IsScoped + .title_ = it.Title + .fileName_ = it.FileName + End With + Set GetLawInfo = iLaw +End Function + +Public Function FillLawsStatus(ByRef targetDocs As Scripting.Dictionary) + Dim aGid As Variant + For Each aGid In targetDocs + targetDocs(aGid) = GetLawStatus(CLng(aGid)) + Next aGid +End Function + +Public Function Cache(gid&) As ItemCachedLaw + Debug.Assert Contains(gid) + Set Cache = index_(gid) +End Function + +Public Function Data(gid&) As IteratorLaw + Debug.Assert Contains(gid) + + Set Data = New IteratorLaw + Call Data.Init(Me, docs_, Cache(gid).row_) +End Function + +Public Function FindByFileName(sName$) As IteratorLaw + If sName = vbNullString Then _ + Exit Function + + Dim result As IteratorLaw: Set result = Me.Laws + If result.Find(sName, S_D_FILENAME) Then + Set FindByFileName = result + End If +End Function + +Public Function FindUnresolvedLink() As IteratorLinkAll + Dim iLink As IteratorLinkAll: Set iLink = Links + Do While Not iLink.IsDone + If Not iLink.IsProcessed Then + Set FindUnresolvedLink = iLink + Exit Function + End If + Call iLink.Increment + Loop +End Function + +Public Function LawLinks(gid&) As IteratorLinkLaw + If Not HasLinksFor(gid) Then _ + Exit Function + Set LawLinks = New IteratorLinkLaw + Call LawLinks.Init(Me, links_, gid) +End Function + +Public Function LawLinksCached(gid&) As IteratorLinkCached + If Not HasLinksFor(gid) Then _ + Exit Function + + Dim iCache() As Long: iCache = uiControl_.Run("GetLinksDump", gid) + Set LawLinksCached = New IteratorLinkCached + Call LawLinksCached.Init(Me, links_, gid, iCache) +End Function + +Public Function Links() As IteratorLinkAll + Set Links = New IteratorLinkAll + Call Links.Init(Me, links_) +End Function + +Public Function Laws() As IteratorLaw + Set Laws = New IteratorLaw + Call Laws.Init(Me, docs_) +End Function + +Public Property Get DocumentsRelativePath() As String + Dim dbPath$: dbPath = database_.Path + Dim nPrefix&: nPrefix = VBA.InStr(docsLocation_, dbPath) + If dbPath = "" Or nPrefix = 0 Then + DocumentsRelativePath = docsLocation_ & "\" + ElseIf docsLocation_ = dbPath Then + DocumentsRelativePath = ".\" + Else + DocumentsRelativePath = ".\" & VBA.Right(docsLocation_, VBA.Len(docsLocation_) - nPrefix - VBA.Len(dbPath)) & "\" + End If +End Property + +Public Function GenerateFileName(sTitle$) As String + GenerateFileName = VBA.Format(GetNextFileIndex(docsLocation_), "0000") & " " & SafeFileName(VBA.Trim(VBA.Left(sTitle, 80))) & HT03_DOC_EXTENSION +End Function + +' ========= Actions ============= +Public Function Validate() As InfoDatabase + Set Validate = Me + If NeedUpdate Then _ + Call Recreate +End Function + +Public Function Recreate(Optional bForceLoadFromServer As Boolean = False) + Set index_ = New Scripting.Dictionary + hash_ = GetDatabaseHash(database_) + + If TypeOf Application Is Excel.Application And Not bForceLoadFromServer Then + If ThisWorkbook.Application = database_.Application Then + Call LoadFromData + Exit Function + End If + End If + Call LoadFromServer +End Function + +Public Function GenerateID(sSeed$) As Long + Dim gid&: gid = GenerateNewGID(sSeed & VBA.CStr(Rnd())) + Do While Contains(gid) + gid = GenerateNewGID(sSeed & VBA.CStr(Rnd())) + Loop + GenerateID = gid +End Function + +Public Function ShowDB() + database_.Application.WindowState = xlMaximized + Call AppActivate(database_.Application.Caption) +End Function + +Public Function SetItem(newItem As ItemLaw) As ItemCachedLaw + Dim iLaw As IteratorLaw: Set iLaw = GetIterFor(newItem.gid_, newItem.status_) + Call iLaw.SetData(newItem, LinkBaseFor(newItem.gid_)) + + If index_.Exists(newItem.gid_) Then _ + Call index_.Remove(newItem.gid_) + + Dim newCachedItem As ItemCachedLaw: Set newCachedItem = iLaw.CreateIndexItem + Call index_.Add(newItem.gid_, newCachedItem) + Set SetItem = newCachedItem + + hash_ = GetDatabaseHash(database_) +End Function + +Public Function SetLinksFor(target&, linksData() As String) As Boolean + Debug.Assert Contains(target) + SetLinksFor = False + + If Not ValidateLinksData(linksData) Then _ + Exit Function + + Call uiControl_.Run("SetLinksFor", target, linksData) + + Cache(target).linkBase_ = Data(target).LinkBase + hash_ = GetDatabaseHash(database_) + + SetLinksFor = True +End Function + +Public Function RenameLawFile(target&, newName$) As Boolean + Debug.Assert Contains(target) + + If newName = vbNullString Then _ + Exit Function + + Dim newFullName$: newFullName = docsLocation_ & "\" & newName + Dim oldFullName$: oldFullName = docsLocation_ & "\" & Data(target).FileName + + Dim fso As New Scripting.FileSystemObject + If Not fso.FileExists(oldFullName) Then _ + Exit Function + + RenameLawFile = newFullName <> oldFullName + If Not RenameLawFile Then _ + Exit Function + + On Error GoTo CANNOT_MOVE + Call fso.MoveFile(oldFullName, newFullName) + On Error GoTo 0 + + Data(target).FileName = newName + hash_ = GetDatabaseHash(database_) + Exit Function + +CANNOT_MOVE: + RenameLawFile = False +End Function + +Public Function IgnoreLaw(target&) As Boolean + IgnoreLaw = True + If Not Contains(target) Then + Call AddIgnoredDummy(target) + ElseIf Cache(target).status_ <> T_LAWS_IGNORE Then + Data(target).Status = T_LAWS_IGNORE + Cache(target).status_ = T_LAWS_IGNORE + hash_ = GetDatabaseHash(database_) + Else + IgnoreLaw = False + End If +End Function + +Public Function DeleteLaw(target&) As Boolean + DeleteLaw = Contains(target) + If Not DeleteLaw Then _ + Exit Function + Call uiControl_.Run("DeleteLaw", target) + Call Recreate +End Function + +Public Function DeleteSomeLinksFor(target&, nIndexStart&, nCount&) As Boolean + DeleteSomeLinksFor = False + + If nIndexStart < 1 Or nCount <= 0 Then _ + Exit Function + Dim itLink As IteratorLinkLaw: Set itLink = LawLinks(target) + If itLink Is Nothing Then _ + Exit Function + + If Not itLink.Increment(nIndexStart - 1) Then _ + Exit Function + Dim nStart&: nStart = itLink.Row + + If Not itLink.Increment(nCount - 1) Then _ + Exit Function + Dim nEnd&: nEnd = itLink.Row + + If Not itLink.Increment Then _ + Call SetLinkBaseInternal(target, HT03_INVALID_ROW) + + Call DeleteLinksInternal(nStart, nEnd) + + DeleteSomeLinksFor = True +End Function + +Public Function DeleteLinksFor(target&) As Boolean + DeleteLinksFor = False + + Dim itLink As IteratorLinkLaw: Set itLink = LawLinks(target) + If itLink Is Nothing Then _ + Exit Function + + Dim nStart&: nStart = itLink.Row + Do While itLink.Increment() + Loop + Dim nEnd&: nEnd = itLink.Row + + Call SetLinkBaseInternal(target, HT03_INVALID_ROW) + Call DeleteLinksInternal(nStart, nEnd) + + DeleteLinksFor = True +End Function + +Public Function AddLinkAfter(gidFrom&, nWhere&, gidTo&, subTo$, subFrom$, lnkType As TLinkType) As Boolean + AddLinkAfter = False + If Not Contains(gidFrom) Or nWhere < 0 Then _ + Exit Function + + Dim bHasLink As Boolean: bHasLink = HasLinksFor(gidFrom) + Dim targetRow&: targetRow = PrepareRowForNewLink(gidFrom, nWhere) + If targetRow = HT03_INVALID_ROW Then _ + Exit Function + + links_.Cells(targetRow, S_L_FROM_SUB) = subFrom + links_.Cells(targetRow, S_L_TO_ID) = gidTo + links_.Cells(targetRow, S_L_TO_SUB) = subTo + links_.Cells(targetRow, S_L_TYPE) = lnkType + links_.Cells(targetRow, S_L_STATUS) = T_LINKS_ADD + + Call FixLinkBaseAfter(IIf(bHasLink, targetRow, targetRow + 1), 1) + hash_ = GetDatabaseHash(database_) + + AddLinkAfter = True +End Function + +' Requires: valid index +Public Function ValidateLinks() As String + If index_.Count = 0 Then _ + Exit Function + + Dim anItem As ItemCachedLaw + Dim aKey As Variant + For Each aKey In index_ + Set anItem = index_(aKey) + anItem.linkBase_ = HT03_INVALID_ROW + Next aKey + + Dim nLast&: nLast = HT03_INVALID_GID + Dim sLog$ + Dim iLink As IteratorLinkAll: Set iLink = Links + Do While Not iLink.IsDone + Dim nSource&: nSource = iLink.SourceID + If nLast = nSource Then _ + GoTo NEXT_LINK + If Not Contains(nSource) Then + sLog = sLog$ & vbNewLine & Fmt("{1}: {2}", iLink.Row, nSource) + links_.Cells(iLink.Row, S_L_FROM_ID).Interior.Color = RGB(0, 0, 255) + ElseIf Cache(nSource).linkBase_ <> HT03_INVALID_ROW Then + sLog = sLog$ & vbNewLine & Fmt("{1}: {2}", iLink.Row, nSource) + links_.Cells(iLink.Row, S_L_FROM_ID).Interior.Color = RGB(255, 0, 0) + Else + Cache(nSource).linkBase_ = iLink.Row + End If + nLast = nSource + +NEXT_LINK: + Call iLink.Increment + Call CSE_ProgressBar.IncrementA + Loop + + For Each aKey In index_ + Data(CLng(aKey)).LinkBase = Cache(CLng(aKey)).linkBase_ + Next aKey + + hash_ = GetDatabaseHash(database_) + + ValidateLinks = sLog +End Function + +' ===== Public Service functions +Public Function IndexDump() As Long() + If index_.Count = 0 Then _ + Exit Function + Dim res() As Long + ReDim res(1 To index_.Count, LawCacheStruct.[_First] To LawCacheStruct.[_Last]) + + Dim nRow&: nRow = 1 + Dim anItem As ItemCachedLaw + Dim aKey As Variant + For Each aKey In index_ + Set anItem = index_(aKey) + res(nRow, S_CD_ID) = anItem.id_ + res(nRow, S_CD_TYPE) = anItem.type_ + res(nRow, S_CD_STATUS) = anItem.status_ + res(nRow, S_CD_LINKBASE) = anItem.linkBase_ + nRow = nRow + 1 + Next aKey + + IndexDump = res +End Function + +Public Function LinksDumpFor(gid&) As Long() + Dim res() As Long + Dim theIter As IteratorLinkLaw: Set theIter = LawLinks(gid) + If theIter Is Nothing Then _ + Exit Function + + Dim nCount&: nCount = 1 + Do While theIter.Increment + nCount = nCount + 1 + Loop + + ReDim res(1 To nCount, LinkCacheStruct.[_First] To LinkCacheStruct.[_Last]) + Call theIter.GoFirst + Dim nItem& + For nItem = 1 To nCount + res(nItem, S_CL_DESTINATION_ID) = theIter.DestinationID + res(nItem, S_CL_TYPE) = theIter.LType + res(nItem, S_CL_STATUS) = theIter.Status + Call theIter.Increment + Next nItem + + LinksDumpFor = res +End Function + +Public Function StartOptimization() + Call uiControl_.PauseUI +End Function + +Public Function EndOptimization() + Call uiControl_.ResumeUI +End Function + +Public Function SetLinksInternal(target&, linksData() As String) + Dim itLink As IteratorLinkAll: Set itLink = Links + Call itLink.GotoInsertion + Dim nStart&: nStart = itLink.Row + Dim nCount&: nCount = ArraySize(linksData, 1) + + Dim nItem& + For nItem = LBound(linksData, 1) To UBound(linksData, 1) Step 1 + With itLink + .DestinationID = CLng(linksData(nItem, S_TL_DESTINATION_ID)) + .DestinationSub = linksData(nItem, S_TL_DESTINATION_SUB) + .SourceID = target + .SourceSub = linksData(nItem, S_TL_SOURCE_SUB) + .LType = T_LINK_DEFAULT + .Status = T_LINKS_ADD + Call .Increment + End With + Next nItem + + Call FixLinkBaseAfter(nStart, nCount) + Call SetLinkBaseInternal(target, nStart) + hash_ = GetDatabaseHash(database_) +End Function + +'==================== +Private Function LoadFromData() + Dim iLaw As IteratorLaw: Set iLaw = Laws + Dim rowsCount&: rowsCount = docs_.UsedRange.Rows.Count + Do While iLaw.Row <= rowsCount + If Not iLaw.IsDone Then _ + If Not index_.Exists(iLaw.ID) Then _ + Call index_.Add(iLaw.ID, iLaw.CreateIndexItem) + Call iLaw.Increment + Loop +End Function + +Private Function LoadFromServer() + Dim iDump() As Long + iDump = uiControl_.Run("GetIndexDump") + If Not IsArrayAllocated(iDump) Then _ + Exit Function + Call LoadFromDump(iDump) +End Function + +' Requires: iDump is valid allocated array +Private Function LoadFromDump(iDump() As Long) + Dim iLaw As IteratorLaw: Set iLaw = Laws + Dim newItem As ItemCachedLaw + Dim nItem& + For nItem = 1 To UBound(iDump, 1) Step 1 + Set newItem = New ItemCachedLaw + newItem.row_ = nItem + HT03_DEFAULT_FIRST_LINE - 1 + newItem.id_ = iDump(nItem, S_CD_ID) + newItem.type_ = iDump(nItem, S_CD_TYPE) + newItem.status_ = iDump(nItem, S_CD_STATUS) + newItem.linkBase_ = iDump(nItem, S_CD_LINKBASE) + ' TODO: check duplicates! + Call index_.Add(newItem.id_, newItem) + Next nItem +End Function + +Private Function GetIterFor(gid&, aStatus As TLawStatus) As IteratorLaw +' Find in DB or create new document entry + If Contains(gid) Then + Set GetIterFor = Data(gid) + Else + Set GetIterFor = CreateRowForNewDoc + End If +End Function + +Private Function LinkBaseFor(gid&) As Long + Dim linksIter As IteratorLinkAll: Set linksIter = Links() + If linksIter.Find(CStr(gid), S_L_FROM_ID) Then + LinkBaseFor = linksIter.Row + Else + LinkBaseFor = HT03_INVALID_ROW + End If +End Function + +Private Function SetLinkBaseInternal(gid&, nRow&) + Data(gid).LinkBase = nRow + Cache(gid).linkBase_ = nRow +End Function + +Private Function CreateRowForNewDoc() As IteratorLaw + Set CreateRowForNewDoc = Laws() + If Not CreateRowForNewDoc.Find(vbNullString, S_D_GARANT_ID) Then + Call Err.Raise(vbObjectError + 513, "InfoDatabase", "Cannot find empty string for insert") + Else + Call docs_.Rows(CreateRowForNewDoc.Row).EntireRow.Insert(CopyOrigin:=xlFormatFromRightOrBelow) + End If +End Function + +Private Function PrepareRowForNewLink(gid&, nWhere&) As Long + PrepareRowForNewLink = HT03_INVALID_ROW + + Dim targetRow&: targetRow = Cache(gid).linkBase_ + If targetRow = HT03_INVALID_ROW Then + If nWhere <> 0 Then _ + Exit Function + Dim it As IteratorLinkAll: Set it = Links + Call it.GotoInsertion + targetRow = it.Row + links_.Cells(targetRow, S_L_FROM_ID) = gid + Call SetLinkBaseInternal(gid, targetRow) + Else + targetRow = targetRow + nWhere - 1 + If links_.Cells(targetRow, S_L_FROM_ID) <> gid Then _ + Exit Function + Call links_.Rows(targetRow).EntireRow.Copy + Call links_.Rows(targetRow).EntireRow.Insert(CopyOrigin:=xlFormatFromRightOrBelow) + targetRow = targetRow + 1 + End If + + PrepareRowForNewLink = targetRow +End Function + +Private Function AddIgnoredDummy(gid&) + Dim iLaw As New ItemLaw + Call iLaw.InitDummy(gid) + iLaw.status_ = T_LAWS_IGNORE + Call SetItem(iLaw) +End Function + +Private Function DeleteLinksInternal(rowStart&, rowEnd&) + Debug.Assert rowStart <= rowEnd + + Dim delCount&: delCount = rowEnd - rowStart + 1 + Dim i& + For i = 1 To delCount Step 1 + Call links_.Rows(rowStart).EntireRow.Delete + Next i + Call FixLinkBaseAfter(rowStart, -delCount) + hash_ = GetDatabaseHash(database_) +End Function + +Private Function FixLinkBaseAfter(nThreshhold&, nDiff&) + Dim dbItem As ItemCachedLaw + Dim aKey As Variant + For Each aKey In index_ + Set dbItem = index_(aKey) + If dbItem.linkBase_ >= nThreshhold Then _ + Call SetLinkBaseInternal(dbItem.id_, dbItem.linkBase_ + nDiff) + Next aKey +End Function + +Private Function ValidateLinksData(linksData() As String) As Boolean + ValidateLinksData = False + + If Not IsArrayAllocated(linksData) Then _ + Exit Function + If LBound(linksData, 2) <> LinkTransferStruct.[_First] Then _ + Exit Function + If UBound(linksData, 2) <> LinkTransferStruct.[_Last] Then _ + Exit Function + + ValidateLinksData = True +End Function + +Public Function GenerateNewGID(sSeed$) As Long + GenerateNewGID = VBA.CStr((MD5AsLong(sSeed) Mod 1000000000) + 1000000000) +End Function + +Private Function GetNextFileIndex(sFolder$) As Long + Dim maxIndex&: maxIndex = 0 + Dim nIndex& + Dim sFileName$: sFileName = Dir(sFolder & "\*" & HT03_DOC_EXTENSION) + Do While sFileName <> vbNullString + nIndex = ExtractFileIndex(sFileName) + maxIndex = IIf(maxIndex < nIndex, nIndex, maxIndex) + sFileName = Dir + Loop + GetNextFileIndex = maxIndex + 1 +End Function + +Private Function ExtractFileIndex(target$) As Long + Dim prefix$: prefix = "" + Dim symb$ + Dim i& + For i = 1 To Len(target) + symb = Mid(target, i, 1) + If Not IsNumeric(symb) Then + i = i - 1 + Exit For + End If + Next i + If i > 1 Then _ + ExtractFileIndex = CLng(Mid(target, 1, i)) +End Function diff --git a/src/common/InfoDocument.cls b/src/common/InfoDocument.cls new file mode 100644 index 0000000..0f62ebe --- /dev/null +++ b/src/common/InfoDocument.cls @@ -0,0 +1,291 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "InfoDocument" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public doc_ As Word.Document +Public gid_ As Long +Public linkSystem_ As TLinkSystem + +Private Sub Class_Initialize() + gid_ = HT03_INVALID_GID + linkSystem_ = DEFAULT_LINK_SYSTEM +End Sub + +Public Function Init(doc As Word.Document) As Boolean + Init = False + + If doc.Hyperlinks.Count = 0 Then _ + Exit Function + + Dim oTitleLink As Word.Hyperlink: Set oTitleLink = doc.Hyperlinks(1) + Dim oFirstPara As Word.Range: Set oFirstPara = doc.Paragraphs(1).Range + If oFirstPara.Start <> oTitleLink.Range.Start Then _ + Exit Function + If VBA.Abs(oFirstPara.End - oTitleLink.Range.End) > 1 Then _ + Exit Function + + Dim iLink As ItemHyperlink: Set iLink = ParseHyperlink(oTitleLink) + Set doc_ = doc + gid_ = iLink.DocumentID + linkSystem_ = iLink.LinkSystem + + Init = True +End Function + +Public Function GetSelection() As Word.Range + Set GetSelection = doc_.Application.Selection.Range +End Function + +Public Function GetLawDescription() As ItemLaw + Dim sTitle$: sTitle = doc_.Paragraphs(1).Range.Text + Dim iLaw As ItemLaw: Set iLaw = ParseLawTitle(sTitle) + If iLaw Is Nothing Then + Set iLaw = New ItemLaw + iLaw.title_ = ApplyCommonAbbreviations(SubstituteWhitespace(sTitle)) + End If + iLaw.gid_ = gid_ + iLaw.fileName_ = doc_.Name + Set GetLawDescription = iLaw +End Function + +Public Function UpdateStyles(sTemplate$) + Dim sTarget$: sTarget = doc_.FullName + Dim sStyle As Variant + For Each sStyle In GetAllLinkStyles() + Call WordCopyStyle(doc_.Application, sTemplate, sTarget, CStr(sStyle)) + Next sStyle +End Function + +Public Function CreateTitleLink() + Dim iLink As New ItemHyperlink: Call iLink.Init(linkSystem_, gid_) + Dim rTitle As Word.Range: Set rTitle = doc_.Paragraphs(1).Range + rTitle.End = rTitle.End - 1 + Call rTitle.Hyperlinks.Add(rTitle, iLink.ToAddress()) +End Function + +Public Function AddHyperlink(target As Word.Range, iLink As ItemLink, sStyle$) As Boolean + AddHyperlink = False + + If target.End <= target.Start Then _ + Exit Function + On Error GoTo RETURN_FALSE + + Dim newLink As New ItemHyperlink: Call newLink.Init(linkSystem_, iLink.destID_, iLink.destSub_) + Call target.Hyperlinks.Add(target, newLink.ToAddress()) + target.Style = target.Document.Styles(sStyle) + If iLink.sourceSub_ <> vbNullString Then + Dim rBookmark As Word.Range: Set rBookmark = target.Paragraphs(1).Range + Dim sBookmarkName$: sBookmarkName = iLink.sourceSub_ + If Not rBookmark.Bookmarks.Exists(sBookmarkName) Then + If doc_.Bookmarks.Exists(sBookmarkName) Then _ + Exit Function + Call rBookmark.Bookmarks.Add(sBookmarkName, rBookmark) + End If + End If + On Error GoTo 0 + + AddHyperlink = True + Exit Function + +RETURN_FALSE: +End Function + +Public Function FormatLink(target As Word.Hyperlink, _ + nLinkType As TLinkType, nLinkStatus As TLinkStatus, _ + sSource As TLawStatus, sDestination As TLawStatus) + Dim sStyle$: sStyle = doc_.Styles(GetLinkStatusStyle(sSource, sDestination, nLinkType)) + With target.Range + .Style = sStyle + .Font.StrikeThrough = nLinkStatus = T_LINKS_IGNORE + End With +End Function + +Public Function ApplyLinkStatus(target As Word.Hyperlink, nLinkStatus As TLinkStatus) + target.Range.Font.StrikeThrough = nLinkStatus = T_LINKS_IGNORE +End Function + +Public Function CountLinksBefore(nTarget&) As Long + Dim aLink As Word.Hyperlink + For Each aLink In doc_.Hyperlinks + If aLink.Range.Start >= nTarget Then _ + Exit Function + If IsHyperlinkValid(aLink) Then _ + CountLinksBefore = CountLinksBefore + 1 + Next aLink +End Function + +Public Function CountLinksIn(target As Word.Range) As Long + Dim docHLink As Word.Hyperlink + For Each docHLink In target.Hyperlinks + If IsHyperlinkValid(docHLink) Then _ + CountLinksIn = CountLinksIn + 1 + Next docHLink +End Function + +' Requires theDB.Contains(nDestination) +Public Function UpdateLinkTip(target As Word.Hyperlink, nDestination&, theDB As InfoDatabase) + Const MAX_TIP_LENGTH% = 255 + Dim sTip$: sTip = Left(theDB.Data(nDestination).Title, MAX_TIP_LENGTH) + If sTip <> vbNullString Then _ + target.ScreenTip = sTip +End Function + +Public Function UpdateFormat(theDB As InfoDatabase) As Long + If Not theDB.HasLinksFor(gid_) Then _ + Call Err.Raise(ERR_LINKS_MISSING) + + Dim nUnresolved&: nUnresolved = 0 + Dim sSource As TLawStatus: sSource = theDB.Cache(gid_).status_ + + Dim itLink As IteratorLinkCached: Set itLink = theDB.LawLinksCached(gid_) + Dim bNoMoreLinks As Boolean: bNoMoreLinks = False + Dim docHLink As Word.Hyperlink + For Each docHLink In doc_.Hyperlinks + Dim iLink As ItemHyperlink: Set iLink = ParseHyperlink(docHLink) + If iLink Is Nothing Then _ + GoTo NEXT_LINK + If bNoMoreLinks Then _ + Call Err.Raise(ERR_SYNC_DB) + Call iLink.ValidateSync(itLink) + + Dim nDestination&: nDestination = itLink.DestinationID + If nDestination = gid_ And itLink.IsFirst Then _ + GoTo INCREMENT_LINK + Call FormatLink(docHLink, itLink.LType, itLink.Status, sSource, theDB.GetLawStatus(nDestination)) + If theDB.Contains(nDestination) Then _ + If docHLink.ScreenTip Like "http*" Or docHLink.ScreenTip = vbNullString Then _ + Call UpdateLinkTip(docHLink, nDestination, theDB) + + If Not itLink.IsProcessed Then _ + nUnresolved = nUnresolved + 1 +INCREMENT_LINK: + bNoMoreLinks = Not itLink.Increment +NEXT_LINK: + Call CSE_ProgressBar.IncrementA + Next docHLink + + If itLink.Increment Then _ + Call Err.Raise(ERR_SYNC_DOC) + + UpdateFormat = nUnresolved& +End Function + +Public Function UpdateFormatFilter(docsFilter As Scripting.Dictionary, theDB As InfoDatabase) + Dim sSource As TLawStatus: sSource = theDB.Cache(gid_).status_ + + Dim itLink As IteratorLinkCached: Set itLink = theDB.LawLinksCached(gid_) + Dim bNoMoreLinks As Boolean: bNoMoreLinks = False + Dim docHLink As Word.Hyperlink + For Each docHLink In doc_.Hyperlinks + Dim iLink As ItemHyperlink: Set iLink = ParseHyperlink(docHLink) + If iLink Is Nothing Then _ + GoTo NEXT_LINK + If bNoMoreLinks Then _ + Exit Function + Call iLink.ValidateSync(itLink) + + Dim nDestination&: nDestination = itLink.DestinationID + If Not docsFilter.Exists(nDestination) Then _ + Call FormatLink(docHLink, itLink.LType, itLink.Status, sSource, theDB.GetLawStatus(nDestination)) + bNoMoreLinks = Not itLink.Increment +NEXT_LINK: + Next docHLink +End Function + +Public Function FindNextUnresolved(posStart&) As Word.Hyperlink + If posStart >= doc_.Range.End Then _ + Exit Function + If posStart < 0 Then _ + posStart = 0 + + Dim searchArea As Word.Range: Set searchArea = doc_.Range(posStart, doc_.Range.End) + Set FindNextUnresolved = NextUnresolvedIn(searchArea) + If Not FindNextUnresolved Is Nothing Then _ + Exit Function + If posStart <= doc_.Paragraphs(1).Range.End Then _ + Exit Function + + Set searchArea = doc_.Range(doc_.Paragraphs(1).Range.End, posStart) + Set FindNextUnresolved = NextUnresolvedIn(searchArea) +End Function + +Public Function IgnoreLawLinks(docsToIgnore As Scripting.Dictionary) + If docsToIgnore.Count = 0 Then _ + Exit Function + + Dim iLink As ItemHyperlink + Dim docHLink As Word.Hyperlink + For Each docHLink In doc_.Hyperlinks + Set iLink = ParseHyperlink(docHLink) + If Not iLink Is Nothing Then + If docsToIgnore.Exists(iLink.DocumentID) Then + Dim bTmp As Boolean: bTmp = docHLink.Range.Font.StrikeThrough + docHLink.Range.Style = Style4A + docHLink.Range.Font.StrikeThrough = bTmp + End If + End If + Next docHLink +End Function + +Public Function RemoveLinksFrom(target As Word.Range) + Dim aLink As Word.Hyperlink + Dim n&: n = 1 + Do While n <= target.Hyperlinks.Count + Set aLink = target.Hyperlinks.Item(n) + If IsHyperlinkValid(aLink) Then + aLink.Range.Style = wdStyleDefaultParagraphFont + Call aLink.Delete + Else + n = n + 1 + End If + Loop +End Function + +Public Function GetParagraphLink(target As Word.Range) As String + If target.Bookmarks.Count = 0 Then _ + Exit Function + GetParagraphLink = CStr(gid_) & "#" & target.Bookmarks(1).Name +End Function + +' ======= +Private Function NextUnresolvedIn(target As Word.Range) As Word.Hyperlink + Dim hLink As Word.Hyperlink + For Each hLink In target.Hyperlinks + If IsUnresolved(hLink) Then + Set NextUnresolvedIn = hLink + Exit Function + End If + Next hLink +End Function + +Private Function IsUnresolved(target As Word.Hyperlink) As Boolean + IsUnresolved = False + + If Not IsHyperlinkValid(target) Then _ + Exit Function + + Dim rLink As Word.Range: Set rLink = target.Range.Duplicate + rLink.Start = rLink.End - 2 + rLink.End = rLink.End - 1 + If rLink.Font.StrikeThrough Then _ + Exit Function + + Dim sStyle$: sStyle = rLink.Style + IsUnresolved = Not IsStyleProcessedWord(sStyle) +End Function + +Private Function IsStyleProcessedWord(aName$) As Boolean + IsStyleProcessedWord = False + If aName = Style0A Then Exit Function + If aName = Style10 Then Exit Function + If aName = Style20 Then Exit Function + If aName = Style30 Then Exit Function + IsStyleProcessedWord = True +End Function diff --git a/src/common/ItemCachedLaw.cls b/src/common/ItemCachedLaw.cls new file mode 100644 index 0000000..02c3ff9 --- /dev/null +++ b/src/common/ItemCachedLaw.cls @@ -0,0 +1,40 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ItemCachedLaw" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ========== =================== +Option Explicit + +Public id_ As Long +Public status_ As TLawStatus +Public type_ As TLawType +Public linkBase_ As Long +Public row_ As Long + +Public Function IsActive() As Boolean + IsActive = status_ = T_LAWS_FULL Or status_ = T_LAWS_FRINGE Or status_ = T_LAWS_OUTER +End Function + +Public Function HasLinks() As Boolean + HasLinks = status_ = T_LAWS_FULL Or status_ = T_LAWS_FRINGE +End Function + +Private Sub Class_Initialize() + row_ = HT03_INVALID_ROW + id_ = HT03_INVALID_GID +End Sub + +Public Function Init(di As IteratorLaw) + With di + id_ = .ID + row_ = .Row + status_ = .Status + type_ = .DType + linkBase_ = .LinkBase + End With +End Function diff --git a/src/common/ItemDocumentModification.cls b/src/common/ItemDocumentModification.cls new file mode 100644 index 0000000..b835de7 --- /dev/null +++ b/src/common/ItemDocumentModification.cls @@ -0,0 +1,20 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ItemDocumentModification" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public deleteRevision_ As Boolean +Public deleteComment_ As Boolean +Public deleteImages_ As Boolean + +Public Function Init(bRevisions As Boolean, bComments As Boolean) + deleteRevision_ = bRevisions + deleteComment_ = bComments + deleteImages_ = False +End Function diff --git a/src/common/ItemHyperlink.cls b/src/common/ItemHyperlink.cls new file mode 100644 index 0000000..377fb74 --- /dev/null +++ b/src/common/ItemHyperlink.cls @@ -0,0 +1,134 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ItemHyperlink" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' Parsed data hyperlink +Option Explicit + +Private gid_ As Long +Private bookmark_ As String +Private system_ As TLinkSystem + +Private Sub Class_Initialize() + gid_ = HT03_INVALID_GID + bookmark_ = "" + system_ = PT_INVALID +End Sub + +Public Function Init(iSystem As TLinkSystem, gid&, Optional sBookmark$ = "sub_0") + gid_ = gid + bookmark_ = sBookmark + system_ = iSystem +End Function + +Public Property Get DocumentID() As Long + DocumentID = gid_ +End Property + +Public Property Get BookmarkName() As String + BookmarkName = bookmark_ +End Property + +Public Property Get LinkSystem() As TLinkSystem + LinkSystem = system_ +End Property + +Public Property Let DocumentID(newVal&) + gid_ = newVal +End Property + +Public Property Let BookmarkName(newVal$) + bookmark_ = newVal +End Property + +Public Property Let LinkSystem(newVal As TLinkSystem) + system_ = newVal +End Property + +Public Function FromAddress(addr$) As Boolean + FromAddress = False + Dim iSystem As TLinkSystem: iSystem = ExtractSystem(addr) + If iSystem = PT_INVALID Then _ + Exit Function + + Dim dataSuffix$: dataSuffix = CutPrefix(addr, iSystem) + If dataSuffix = vbNullString Then _ + Exit Function + Dim gidStr$: gidStr = VBA.Left(dataSuffix, VBA.InStr(1, dataSuffix, ".") - 1) + If Not IsNumeric(gidStr) Then _ + Exit Function + + Dim strSub$: strSub = VBA.Right(dataSuffix, VBA.Len(dataSuffix) - VBA.InStr(dataSuffix, ".")) + If Not IsNumeric(strSub) Then _ + Exit Function + + system_ = iSystem + gid_ = CLng(gidStr) + bookmark_ = "sub_" & strSub + + FromAddress = True +End Function + +Public Function ToAddress() As String + Dim sBookmarkID$: sBookmarkID = GetBookmarkHyperlink + Select Case system_ + Case PT_MOBILE: ToAddress = Fmt("http://mobileonline.garant.ru/document/redirect/{1}/{2}", gid_, sBookmarkID) + Case PT_LOCAL: ToAddress = Fmt("garantf1://{1}.{2}/", gid_, sBookmarkID) + Case PT_INTERNET: ToAddress = Fmt("http://internet.garant.ru/document/redirect/{1}/{2}", gid_, sBookmarkID) + End Select +End Function + +Public Function ValidateSync(itLink As IteratorLinkCached) + If itLink.DestinationID <> gid_ Then _ + Call Err.Raise(ERR_SYNC_LINK_ID, Description:=CStr(itLink.DestinationID) & "!=" & CStr(gid_)) +End Function + +' =========================== +Private Function CutPrefix(aLink$, iSystem As TLinkSystem) As String + Select Case iSystem + Case PT_MOBILE + CutPrefix = VBA.Right(aLink, VBA.Len(aLink) - 48) ' 48 = VBA.Len(PrefixFor(PT_MOBILE)) + CutPrefix = Replace(CutPrefix, "/", ".") + Case PT_LOCAL + CutPrefix = VBA.Right(aLink, VBA.Len(aLink) - VBA.InStr(1, aLink, "//") - 1) + CutPrefix = VBA.Left(CutPrefix, VBA.Len(CutPrefix) - 1) + Case PT_INTERNET + CutPrefix = VBA.Right(aLink, VBA.Len(aLink) - 44) ' 44 = Len(PrefixFor(PT_INTERNET)) + CutPrefix = VBA.Replace(CutPrefix, "/", ".") + End Select + If Not CutPrefix Like "*.*" Then _ + CutPrefix = vbNullString +End Function + +Private Function PrefixFor(aType As TLinkSystem) As String + Select Case aType + Case PT_MOBILE: PrefixFor = "http://mobileonline.garant.ru/document/redirect/" + Case PT_LOCAL: PrefixFor = "garantf1://" + Case PT_INTERNET: PrefixFor = "http://internet.garant.ru/document/redirect/" + End Select +End Function + +Private Function ExtractSystem(sAddress$) As TLinkSystem + If InStr(1, sAddress, PrefixFor(PT_MOBILE), vbTextCompare) = 1 Then + ExtractSystem = PT_MOBILE + ElseIf InStr(1, sAddress, PrefixFor(PT_LOCAL), vbTextCompare) = 1 Then + ExtractSystem = PT_LOCAL + ElseIf InStr(1, sAddress, PrefixFor(PT_INTERNET), vbTextCompare) = 1 Then + ExtractSystem = PT_INTERNET + Else + ExtractSystem = PT_INVALID + End If +End Function + +Private Function GetBookmarkHyperlink() As String + If Len(bookmark_) <= 4 Then + GetBookmarkHyperlink = "0" + Else + GetBookmarkHyperlink = Right(bookmark_, Len(bookmark_) - 4) + End If +End Function diff --git a/src/common/ItemLaw.cls b/src/common/ItemLaw.cls new file mode 100644 index 0000000..e868667 --- /dev/null +++ b/src/common/ItemLaw.cls @@ -0,0 +1,62 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ItemLaw" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +' Cannot be parsed from title +Public gid_ As Long +Public status_ As TLawStatus +Public isDummy_ As Boolean +Public fileName_ As String + +' Can be parsed or infered from law title +Public type_ As TLawType +Public title_ As String +Public typeTxt_ As String +Public creator_ As String +Public date_ As String +Public number_ As String +Public header_ As String +Public attach_ As String +Public isScoped_ As Boolean + +Private Sub Class_Initialize() + gid_ = HT03_INVALID_GID + type_ = T_LAW_01_UNKNOWN + status_ = T_LAWS_FULL + isScoped_ = False + isDummy_ = False +End Sub + +Public Function Clone() As ItemLaw + Set Clone = New ItemLaw + With Clone + .gid_ = gid_ + .status_ = status_ + .type_ = type_ + .fileName_ = fileName_ + .title_ = title_ + .typeTxt_ = typeTxt_ + .creator_ = creator_ + .date_ = date_ + .number_ = number_ + .header_ = header_ + .attach_ = attach_ + .isScoped_ = isScoped_ + .isDummy_ = isDummy_ + End With +End Function + +Public Function InitDummy(gid&) + gid_ = gid + type_ = T_LAW_01_UNKNOWN + fileName_ = HT03_FILE_NOT_LOADED + title_ = HT03_TITLE_NOT_LOADED + isDummy_ = True +End Function diff --git a/src/common/ItemLink.cls b/src/common/ItemLink.cls new file mode 100644 index 0000000..6c767c7 --- /dev/null +++ b/src/common/ItemLink.cls @@ -0,0 +1,37 @@ +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 sourceID_ As Long +Public sourceSub_ As String + +Public destID_ As Long +Public destSub_ As String + +Public type_ As TLinkType + +Public Function Init(nSource&, bmSource$, nDestination&, bmDestination$, nType As TLinkType) + sourceID_ = nSource + sourceSub_ = bmSource + destID_ = nDestination + destSub_ = bmDestination + type_ = nType +End Function + +Public Function Clone() As ItemLink + Set Clone = New ItemLink + With Clone + .sourceID_ = sourceID_ + .sourceSub_ = sourceSub_ + .destID_ = destID_ + .destSub_ = destSub_ + .type_ = type_ + End With +End Function diff --git a/src/common/IteratorLaw.cls b/src/common/IteratorLaw.cls new file mode 100644 index 0000000..3a3ae5d --- /dev/null +++ b/src/common/IteratorLaw.cls @@ -0,0 +1,274 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "IteratorLaw" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private index_ As InfoDatabase +Private row_ As Long +Private sheet_ As Excel.Worksheet + +Public Function Init(theDB As InfoDatabase, target As Excel.Worksheet, Optional nRow& = HT03_DEFAULT_FIRST_LINE) + Set index_ = theDB + Set sheet_ = target + row_ = nRow +End Function + +Public Function Increment(Optional inc& = 1) + If row_ + inc > 0 Then _ + row_ = row_ + inc +End Function + +Public Function GoFirst() + row_ = HT03_DEFAULT_FIRST_LINE +End Function + +Public Function GoLast() + row_ = sheet_.Columns(S_D_GARANT_ID).Find(vbNullString, LookAt:=xlWhole).Row - 1 + If row_ < HT03_DEFAULT_FIRST_LINE Then _ + row_ = HT03_DEFAULT_FIRST_LINE +End Function + +Public Function IsDone() As Boolean + IsDone = sheet_.Cells(row_, LawStruct.S_D_GARANT_ID) = vbNullString +End Function + +Public Function HasInfoBlanks() As Boolean + HasInfoBlanks = True + + If TypeText = vbNullString Then _ + Exit Function + If Creator = vbNullString Then _ + Exit Function + If CreationDate = vbNullString Then _ + Exit Function + If Number = vbNullString Then _ + Exit Function + If Header = vbNullString Then _ + Exit Function + If Attachment = vbNullString Then _ + Exit Function + If sheet_.Cells(row_, LawStruct.S_D_TIME_SCOPED) = vbNullString Then _ + Exit Function + + HasInfoBlanks = False +End Function + +Public Function IsActive() As Boolean + Dim theStatus As TLawStatus: theStatus = Status + IsActive = theStatus = T_LAWS_FULL Or theStatus = T_LAWS_FRINGE Or theStatus = T_LAWS_OUTER +End Function + +Public Function HasLinks() As Boolean + Dim theStatus As TLawStatus: theStatus = Status + HasLinks = theStatus = T_LAWS_FULL Or theStatus = T_LAWS_FRINGE +End Function + +Public Function HasFile() As Boolean + Dim sFile$: sFile = FileName + HasFile = sFile <> HT03_FILE_NOT_LOADED And sFile <> vbNullString +End Function + +Public Function IsLoaded() As Boolean + Dim sTitle$: sTitle = Title + IsLoaded = sTitle <> HT03_TITLE_NOT_LOADED And sTitle <> vbNullString And Not IsDummy +End Function + +Public Function CreateIndexItem() As ItemCachedLaw + Dim result As New ItemCachedLaw + Call result.Init(Me) + Set CreateIndexItem = result +End Function + +Public Function Links() As IteratorLinkLaw + Set Links = index_.LawLinks(ID) +End Function + +Public Function Find(target$, colN As LawStruct) As Boolean + Dim foundRng As Excel.Range: + Set foundRng = sheet_.Columns(colN).Find(target, LookAt:=xlWhole) + Find = Not foundRng Is Nothing + If Find Then _ + row_ = foundRng.Row +End Function + +'===== Get ===== +Public Function GetVaueIn(colID&) As String + GetVaueIn = sheet_.Cells(row_, colID) +End Function + +Public Property Get Data() As ItemLaw + Set Data = New ItemLaw + With Data + .gid_ = ID + .status_ = Status + .type_ = DType + .fileName_ = FileName + .title_ = Title + .typeTxt_ = TypeText + .creator_ = Creator + .date_ = CreationDate + .number_ = Number + .header_ = Header + .attach_ = Attachment + .isScoped_ = IsScoped + .isDummy_ = IsDummy + End With +End Property + +Public Property Get Row() As Long + Row = row_ +End Property + +Public Property Get ID() As Long + ID = CLng(sheet_.Cells(row_, LawStruct.S_D_GARANT_ID)) +End Property + +Public Property Get Status() As TLawStatus + Status = CInt(sheet_.Cells(row_, LawStruct.S_D_STATUS)) +End Property + +Public Property Get DType() As TLawType + DType = CInt(sheet_.Cells(row_, LawStruct.S_D_TYPE)) +End Property + +Public Property Get FileName() As String + FileName = sheet_.Cells(row_, LawStruct.S_D_FILENAME) +End Property + +Public Property Get Title() As String + Title = sheet_.Cells(row_, LawStruct.S_D_TITLE) +End Property + +Public Property Get TypeText() As String + TypeText = sheet_.Cells(row_, LawStruct.S_D_TYPE_TXT) +End Property + +Public Property Get Creator() As String + Creator = sheet_.Cells(row_, LawStruct.S_D_CREATOR) +End Property + +Public Property Get CreationDate() As String + CreationDate = sheet_.Cells(row_, LawStruct.S_D_DATE) +End Property + +Public Property Get Number() As String + Number = sheet_.Cells(row_, LawStruct.S_D_NUMBER) +End Property + +Public Property Get Header() As String + Header = sheet_.Cells(row_, LawStruct.S_D_HEADER) +End Property + +Public Property Get Attachment() As String + Attachment = sheet_.Cells(row_, LawStruct.S_D_ATTACH) +End Property + +Public Property Get IsScoped() As Boolean + IsScoped = sheet_.Cells(row_, LawStruct.S_D_TIME_SCOPED) = 1 +End Property + +Public Property Get IsDummy() As Boolean + IsDummy = sheet_.Cells(row_, LawStruct.S_D_IS_DUMMY) = 1 +End Property + +Public Property Get LinkBase() As Long + LinkBase = CLng(sheet_.Cells(row_, LawStruct.S_D_LINKBASE)) +End Property + +'===== Let ===== +Public Function SetData(dataItem As ItemLaw, nLinkBase&) +' ( ) + With sheet_ + .Cells(row_, S_D_GARANT_ID) = dataItem.gid_ + .Cells(row_, S_D_STATUS) = dataItem.status_ + .Cells(row_, S_D_TYPE) = dataItem.type_ + .Cells(row_, S_D_TITLE) = dataItem.title_ + .Cells(row_, S_D_TYPE_TXT) = dataItem.typeTxt_ + .Cells(row_, S_D_CREATOR) = dataItem.creator_ + .Cells(row_, S_D_DATE) = dataItem.date_ + .Cells(row_, S_D_NUMBER) = dataItem.number_ + .Cells(row_, S_D_HEADER) = dataItem.header_ + .Cells(row_, S_D_ATTACH) = dataItem.attach_ + .Cells(row_, S_D_TIME_SCOPED) = IIf(dataItem.isScoped_, 1, 0) + .Cells(row_, S_D_IS_DUMMY) = IIf(dataItem.isDummy_, 1, 0) + .Cells(row_, S_D_LINKBASE) = nLinkBase + End With + FileName = dataItem.fileName_ +End Function + +Public Function SetVaueIn(colID&, val As Variant) + sheet_.Cells(row_, colID) = val +End Function + +Public Property Let Row(theRow&) + row_ = theRow +End Property + +Public Property Let ID(nID&) + sheet_.Cells(row_, LawStruct.S_D_GARANT_ID) = nID +End Property + +Public Property Let Status(nStat As TLawStatus) + sheet_.Cells(row_, LawStruct.S_D_STATUS) = nStat +End Property + +Public Property Let DType(nType As TLawType) + sheet_.Cells(row_, LawStruct.S_D_TYPE) = nType +End Property + +Public Property Let FileName(sNewFile$) + Dim aCell As Excel.Range: Set aCell = sheet_.Cells(row_, LawStruct.S_D_FILENAME) + + aCell = sNewFile + Call aCell.Hyperlinks.Delete + If sNewFile = vbNullString Or sNewFile = HT03_FILE_NOT_LOADED Then _ + Exit Property + + Call aCell.Hyperlinks.Add(aCell, index_.DocumentsRelativePath & sNewFile) +End Property + +Public Property Let Title(ntitle$) + sheet_.Cells(row_, LawStruct.S_D_TITLE) = ntitle +End Property + +Public Property Let TypeText(sType$) + sheet_.Cells(row_, LawStruct.S_D_TYPE_TXT) = sType +End Property + +Public Property Let Creator(sCreator$) + sheet_.Cells(row_, LawStruct.S_D_CREATOR) = sCreator +End Property + +Public Property Let CreationDate(sDate$) + sheet_.Cells(row_, LawStruct.S_D_DATE) = sDate +End Property + +Public Property Let Number(sNumber$) + sheet_.Cells(row_, LawStruct.S_D_NUMBER) = sNumber +End Property + +Public Property Let Header(sHeader$) + sheet_.Cells(row_, LawStruct.S_D_HEADER) = sHeader +End Property + +Public Property Let Attachment(sTitle$) + sheet_.Cells(row_, LawStruct.S_D_ATTACH) = sTitle +End Property + +Public Property Let IsScoped(bValue As Boolean) + sheet_.Cells(row_, LawStruct.S_D_TIME_SCOPED) = IIf(bValue, 1, 0) +End Property + +Public Property Let IsDummy(bValue As Boolean) + sheet_.Cells(row_, LawStruct.S_D_IS_DUMMY) = IIf(bValue, 1, 0) +End Property + +Public Property Let LinkBase(nRowN&) + sheet_.Cells(row_, LawStruct.S_D_LINKBASE) = nRowN +End Property diff --git a/src/common/IteratorLinkAll.cls b/src/common/IteratorLinkAll.cls new file mode 100644 index 0000000..be53a56 --- /dev/null +++ b/src/common/IteratorLinkAll.cls @@ -0,0 +1,165 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "IteratorLinkAll" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private row_ As Long +Private sheet_ As Excel.Worksheet +Private db_ As InfoDatabase + +Public Sub Init(db As InfoDatabase, linkSheet As Excel.Worksheet, Optional nRow& = HT03_DEFAULT_FIRST_LINE) + Set db_ = db + Set sheet_ = linkSheet + row_ = nRow +End Sub + +Public Function Increment(Optional nStep& = 1) As Boolean + Increment = row_ + nStep >= 0 + If Increment Then _ + row_ = row_ + nStep +End Function + +Public Function GoFirst() + row_ = HT03_DEFAULT_FIRST_LINE +End Function + +Public Function GoLast() + row_ = sheet_.Columns(S_L_FROM_ID).Find(vbNullString, LookAt:=xlWhole).Row - 1 + If row_ < HT03_DEFAULT_FIRST_LINE Then _ + row_ = HT03_DEFAULT_FIRST_LINE +End Function + +Public Function GotoInsertion() + row_ = sheet_.Columns(S_L_FROM_ID).Find(vbNullString, LookAt:=xlWhole).Row +End Function + +Public Function IsDone() As Boolean + IsDone = sheet_.Cells(row_, LinkStruct.S_L_TO_ID) = vbNullString +End Function + +Public Function RemoveRow() + Call sheet_.Rows(row_).Delete +End Function + +Public Function Find(target$, colN As LinkStruct) As Boolean + Dim foundRng As Excel.Range + Set foundRng = sheet_.Columns(colN).Find(target, LookAt:=xlWhole) + If foundRng Is Nothing Then + row_ = HT03_INVALID_ROW + Find = False + Else + row_ = foundRng.Row + Find = True + End If + Set foundRng = sheet_.Columns(colN).Find("", LookAt:=xlPart) +End Function + +Public Function IsProcessed() As Boolean + IsProcessed = True + If Status = T_LINKS_IGNORE Then _ + Exit Function + + Dim nDestination&: nDestination = DestinationID + Dim destStatus As TLawStatus: destStatus = db_.GetLawStatus(nDestination) + If destStatus = T_LAWS_IGNORE Then _ + Exit Function + + Dim nSource&: nSource = SourceID + Dim sourceStatus As TLawStatus: sourceStatus = db_.Cache(nSource).status_ + If sourceStatus = T_LAWS_OUTER Or _ + (sourceStatus = T_LAWS_FRINGE And destStatus = T_LAWS_NOTDEFINED) Then _ + Exit Function + + IsProcessed = LType <> T_LINK_DEFAULT And db_.Contains(nDestination) + If Not IsProcessed And nSource = nDestination Then _ + IsProcessed = Row = db_.Cache(nSource).linkBase_ +End Function + +Public Function IsActive() As Boolean + IsActive = False + If Status = T_LINKS_IGNORE Or LType = T_LINK_DEFAULT Then _ + Exit Function + + If Not db_.Contains(DestinationID) Or Not db_.Contains(SourceID) Then _ + Exit Function + + Dim targetStatus As TLawStatus: targetStatus = db_.GetLawStatus(DestinationID) + If targetStatus = T_LAWS_IGNORE Then _ + Exit Function + + Dim sourceStatus As TLawStatus: sourceStatus = db_.Cache(SourceID).status_ + If sourceStatus = T_LAWS_OUTER Or sourceStatus = T_LAWS_IGNORE Or _ + (sourceStatus = T_LAWS_FRINGE And targetStatus = T_LAWS_NOTDEFINED) Then _ + Exit Function + + IsActive = True +End Function + +Public Function ImportData(src As Object) + SourceID = src.SourceID + SourceSub = src.SourceSub + DestinationID = src.DestinationID + DestinationSub = src.DestinationSub + LType = src.LType + Status = src.Status +End Function + +'===== Let ===== +Public Property Let DestinationID(nID&) + sheet_.Cells(row_, LinkStruct.S_L_TO_ID) = nID +End Property + +Public Property Let Status(nStat As TLinkStatus) + sheet_.Cells(row_, LinkStruct.S_L_STATUS) = nStat +End Property + +Public Property Let LType(nType As TLinkType) + sheet_.Cells(row_, LinkStruct.S_L_TYPE) = nType +End Property + +Public Property Let SourceID(nID&) + sheet_.Cells(row_, LinkStruct.S_L_FROM_ID) = nID +End Property + +Public Property Let DestinationSub(nSub$) + sheet_.Cells(row_, LinkStruct.S_L_TO_SUB) = nSub +End Property + +Public Property Let SourceSub(nSub$) + sheet_.Cells(row_, LinkStruct.S_L_FROM_SUB) = nSub +End Property + +'===== Get ===== +Public Property Get Row() As Long + Row = row_ +End Property + +Public Property Get DestinationID() As Long + DestinationID = CLng(sheet_.Cells(row_, LinkStruct.S_L_TO_ID)) +End Property + +Public Property Get DestinationSub() As String + DestinationSub = sheet_.Cells(row_, LinkStruct.S_L_TO_SUB) +End Property + +Public Property Get SourceID() As Long + SourceID = CLng(sheet_.Cells(row_, LinkStruct.S_L_FROM_ID)) +End Property + +Public Property Get SourceSub() As String + SourceSub = sheet_.Cells(row_, LinkStruct.S_L_FROM_SUB) +End Property + +Public Property Get Status() As TLinkStatus + Status = CInt(sheet_.Cells(row_, LinkStruct.S_L_STATUS)) +End Property + +Public Property Get LType() As TLinkType + LType = CInt(sheet_.Cells(row_, LinkStruct.S_L_TYPE)) +End Property diff --git a/src/common/IteratorLinkCached.cls b/src/common/IteratorLinkCached.cls new file mode 100644 index 0000000..a4a3fba --- /dev/null +++ b/src/common/IteratorLinkCached.cls @@ -0,0 +1,130 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "IteratorLinkCached" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private data_() As Long + +Private baseRow_ As Long +Private itemCount_ As Long + +Private docID_ As Long +Private nItem_ As Long +Private sheet_ As Excel.Worksheet +Private db_ As InfoDatabase + +Private Sub Class_Initialize() + docID_ = HT03_INVALID_GID +End Sub + +Public Sub Init(db As InfoDatabase, linkSheet As Excel.Worksheet, gid&, ByRef cachedData() As Long) + data_ = cachedData + Set db_ = db + Set sheet_ = linkSheet + docID_ = gid + + baseRow_ = db_.Cache(docID_).linkBase_ + nItem_ = 1 + itemCount_ = UBound(data_, 1) - LBound(data_, 1) + 1 +End Sub + +Public Function Increment(Optional nStep& = 1) As Boolean + Increment = nItem_ + nStep >= 0 And nItem_ + nStep <= itemCount_ + If Increment Then _ + nItem_ = nItem_ + nStep +End Function + +Public Function GoFirst() + nItem_ = 1 +End Function + +Public Function IsFirst() As Boolean + IsFirst = nItem_ = 1 +End Function + +Public Function IsProcessed() As Boolean + IsProcessed = True + If Status = T_LINKS_IGNORE Then _ + Exit Function + + Dim nDestination&: nDestination = DestinationID + Dim destStatus As TLawStatus: destStatus = db_.GetLawStatus(nDestination) + If destStatus = T_LAWS_IGNORE Then _ + Exit Function + + Dim sourceStatus As TLawStatus: sourceStatus = db_.Cache(docID_).status_ + If sourceStatus = T_LAWS_OUTER Or _ + (sourceStatus = T_LAWS_FRINGE And destStatus = T_LAWS_NOTDEFINED) Then _ + Exit Function + + IsProcessed = LType <> T_LINK_DEFAULT And db_.Contains(nDestination) + If Not IsProcessed And docID_ = nDestination Then _ + IsProcessed = Row = db_.Cache(docID_).linkBase_ +End Function + +Public Function IsActive() As Boolean + IsActive = False + If Status = T_LINKS_IGNORE Or LType = T_LINK_DEFAULT Then _ + Exit Function + + If Not db_.Contains(DestinationID) Or Not db_.Contains(docID_) Then _ + Exit Function + + Dim targetStatus As TLawStatus: targetStatus = db_.GetLawStatus(DestinationID) + If targetStatus = T_LAWS_IGNORE Then _ + Exit Function + + Dim sourceStatus As TLawStatus: sourceStatus = db_.Cache(docID_).status_ + If sourceStatus = T_LAWS_OUTER Or sourceStatus = T_LAWS_IGNORE Or _ + (sourceStatus = T_LAWS_FRINGE And targetStatus = T_LAWS_NOTDEFINED) Then _ + Exit Function + + IsActive = True +End Function + +Public Function FlipStatus() + Status = IIf(Status = T_LINKS_IGNORE, T_LINKS_ADD, T_LINKS_IGNORE) +End Function + +'===== Let ===== +Public Property Let DestinationID(nID&) + sheet_.Cells(Row, LinkStruct.S_L_TO_ID) = nID + data_(nItem_, S_CL_DESTINATION_ID) = nID +End Property + +Public Property Let Status(nStat As TLinkStatus) + sheet_.Cells(Row, LinkStruct.S_L_STATUS) = nStat + data_(nItem_, S_CL_STATUS) = nStat +End Property + +Public Property Let LType(nType As TLinkType) + sheet_.Cells(Row, LinkStruct.S_L_TYPE) = nType + data_(nItem_, S_CL_TYPE) = nType +End Property + +'===== Get ===== +Public Property Get Row() As Long + Row = baseRow_ + nItem_ - 1 +End Property + +Public Property Get Count() As Long + Count = itemCount_ +End Property + +Public Property Get DestinationID() As Long + DestinationID = data_(nItem_, S_CL_DESTINATION_ID) +End Property + +Public Property Get LType() As TLinkType + LType = data_(nItem_, S_CL_TYPE) +End Property + +Public Property Get Status() As TLinkStatus + Status = data_(nItem_, S_CL_STATUS) +End Property diff --git a/src/common/IteratorLinkLaw.cls b/src/common/IteratorLinkLaw.cls new file mode 100644 index 0000000..fe09f14 --- /dev/null +++ b/src/common/IteratorLinkLaw.cls @@ -0,0 +1,150 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "IteratorLinkLaw" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private docID_ As Long +Private row_ As Long +Private sheet_ As Excel.Worksheet +Private db_ As InfoDatabase + +Private Sub Class_Initialize() + docID_ = HT03_INVALID_GID + row_ = HT03_INVALID_ROW +End Sub + +Public Sub Init(db As InfoDatabase, linkSheet As Excel.Worksheet, gid&) + Set db_ = db + Set sheet_ = linkSheet + docID_ = gid + row_ = db_.Cache(docID_).linkBase_ +End Sub + +Public Function Clone() As IteratorLinkLaw + Set Clone = New IteratorLinkLaw + Call Clone.Init(db_, sheet_, docID_) + Call Clone.Increment(row_ - db_.Cache(docID_).linkBase_) +End Function + +Public Function IsNull() As Boolean + IsNull = db_ Is Nothing Or row_ = HT03_INVALID_ROW +End Function + +Public Function Increment(Optional nStep& = 1) As Boolean + Increment = False + If IsNull Or row_ + nStep <= 0 Then _ + Exit Function + If CLng(sheet_.Cells(row_ + nStep, S_L_FROM_ID)) <> docID_ Then _ + Exit Function + row_ = row_ + nStep + Increment = True +End Function + +Public Function ForceSetRow(nRow&) + row_ = nRow +End Function + +Public Function GoFirst() + row_ = db_.Cache(docID_).linkBase_ +End Function + +Public Function Find(target$, colN As LinkStruct) As Boolean + Dim foundRng As Excel.Range + Set foundRng = sheet_.Columns(colN).Find(target, LookAt:=xlWhole) + If foundRng Is Nothing Then + row_ = HT03_INVALID_ROW + Find = False + Else + row_ = foundRng.Row + Find = True + End If + Set foundRng = sheet_.Columns(colN).Find("", LookAt:=xlPart) +End Function + +Public Function IsProcessed() As Boolean + IsProcessed = True + If Status = T_LINKS_IGNORE Then _ + Exit Function + + Dim nDestination&: nDestination = DestinationID + Dim destStatus As TLawStatus: destStatus = db_.GetLawStatus(nDestination) + If destStatus = T_LAWS_IGNORE Then _ + Exit Function + + Dim sourceStatus As TLawStatus: sourceStatus = db_.Cache(docID_).status_ + If sourceStatus = T_LAWS_OUTER Or _ + (sourceStatus = T_LAWS_FRINGE And destStatus = T_LAWS_NOTDEFINED) Then _ + Exit Function + + IsProcessed = LType <> T_LINK_DEFAULT And db_.Contains(nDestination) + If Not IsProcessed And docID_ = nDestination Then _ + IsProcessed = Row = db_.Cache(docID_).linkBase_ +End Function + +Public Function IsActive() As Boolean + IsActive = False + If Status = T_LINKS_IGNORE Or LType = T_LINK_DEFAULT Then _ + Exit Function + + If Not db_.Contains(DestinationID) Or Not db_.Contains(docID_) Then _ + Exit Function + + Dim targetStatus As TLawStatus: targetStatus = db_.GetLawStatus(DestinationID) + If targetStatus = T_LAWS_IGNORE Then _ + Exit Function + + Dim sourceStatus As TLawStatus: sourceStatus = db_.Cache(docID_).status_ + If sourceStatus = T_LAWS_OUTER Or sourceStatus = T_LAWS_IGNORE Or _ + (sourceStatus = T_LAWS_FRINGE And targetStatus = T_LAWS_NOTDEFINED) Then _ + Exit Function + + IsActive = True +End Function + +'===== Let ===== +Public Property Let DestinationID(nID&) + sheet_.Cells(row_, LinkStruct.S_L_TO_ID) = nID +End Property + +Public Property Let Status(nStat As TLinkStatus) + sheet_.Cells(row_, LinkStruct.S_L_STATUS) = nStat +End Property + +Public Property Let LType(nType As TLinkType) + sheet_.Cells(row_, LinkStruct.S_L_TYPE) = nType +End Property + +Public Property Let SourceSub(nSub$) + sheet_.Cells(row_, LinkStruct.S_L_FROM_SUB) = nSub +End Property + +'===== Get ===== +Public Property Get Row() As Long + Row = row_ +End Property + +Public Property Get DestinationID() As Long + DestinationID = CLng(sheet_.Cells(row_, LinkStruct.S_L_TO_ID)) +End Property + +Public Property Get DestinationSub() As String + DestinationSub = sheet_.Cells(row_, LinkStruct.S_L_TO_SUB) +End Property + +Public Property Get SourceSub() As String + SourceSub = sheet_.Cells(row_, LinkStruct.S_L_FROM_SUB) +End Property + +Public Property Get Status() As TLinkStatus + Status = CInt(sheet_.Cells(row_, LinkStruct.S_L_STATUS)) +End Property + +Public Property Get LType() As TLinkType + LType = CInt(sheet_.Cells(row_, LinkStruct.S_L_TYPE)) +End Property diff --git a/src/database/DataAccess.bas b/src/database/DataAccess.bas new file mode 100644 index 0000000..c5aa5a4 --- /dev/null +++ b/src/database/DataAccess.bas @@ -0,0 +1,97 @@ +Attribute VB_Name = "DataAccess" +Option Private Module +Option Explicit + +Public Function AccessDatabase() As InfoDatabase + Static s_AccessDatabase As InfoDatabase + + On Error GoTo CREATE_NEW + Set AccessDatabase = s_AccessDatabase.Validate + Exit Function + +CREATE_NEW: + Set s_AccessDatabase = New InfoDatabase + Call s_AccessDatabase.Init(ThisWorkbook, GetDocumentsLocation(ThisWorkbook)) + Set AccessDatabase = s_AccessDatabase +End Function + +Public Function SetDocumentsLocation(sDir$) + ThisWorkbook.Names(HT03_CELL_FOLDER).RefersToRange = sDir + AccessDatabase.docsLocation_ = GetDocumentsLocation(ThisWorkbook) +End Function + +Public Function ClearAll() + ThisWorkbook.Names(CELL_STAT_BASE).RefersToRange = 0 + Call SetDocumentsLocation(HT03_DEFAULT_WORKDIR) + Call ThisWorkbook.Sheets(HT03_SHT_DOCS).UsedRange.Offset(1).ClearContents + Call ThisWorkbook.Sheets(HT03_SHT_LINKS).UsedRange.Offset(1).ClearContents +End Function + +Public Function GetIndexDump() As Long() + Dim theDB As InfoDatabase: Set theDB = AccessDatabase + GetIndexDump = theDB.IndexDump +End Function + +Public Function GetLinksDump(target&) As Long() + Dim theDB As InfoDatabase: Set theDB = AccessDatabase + GetLinksDump = theDB.LinksDumpFor(target) +End Function + +Public Function SetLinksFor(target&, linksData() As String) + Dim theDB As InfoDatabase: Set theDB = AccessDatabase + If Not theDB.Contains(target) Then _ + Exit Function + + Call theDB.StartOptimization + + Call theDB.DeleteLinksFor(target) + Call theDB.SetLinksInternal(target, linksData) + + Call theDB.EndOptimization +End Function + +Public Function RemoveLinksFor(target&) As Long + RemoveLinksFor = 0 + Dim lnksSht As Excel.Worksheet: Set lnksSht = ThisWorkbook.Sheets(HT03_SHT_LINKS) + Dim nRow&: nRow = HT03_DEFAULT_FIRST_LINE + Do While lnksSht.Cells(nRow, S_L_FROM_ID) <> vbNullString + If lnksSht.Cells(nRow, S_L_FROM_ID) = target Then + lnksSht.Rows(nRow).Delete + RemoveLinksFor = RemoveLinksFor + 1 + Else + nRow = nRow + 1 + End If + Loop +End Function + +Public Function RemoveIDFromDocs(target&) As String + Dim docsSht As Excel.Worksheet: Set docsSht = ThisWorkbook.Sheets(HT03_SHT_DOCS) + Dim nRow&: nRow = HT03_DEFAULT_FIRST_LINE + Do While docsSht.Cells(nRow, S_D_GARANT_ID) <> vbNullString + If docsSht.Cells(nRow, S_D_GARANT_ID) = target Then + Dim theFile$: theFile = docsSht.Cells(nRow, S_D_FILENAME) + If theFile <> HT03_FILE_NOT_LOADED Then + theFile = AccessDatabase.docsLocation_ & "/" & theFile + Else + theFile = vbNullString + End If + docsSht.Rows(nRow).Delete + RemoveIDFromDocs = theFile + Exit Function + End If + nRow = nRow + 1 + Loop +End Function + +Public Function SubstituteLinks(nDelete&, nSubstitute&) + Dim lnksSht As Excel.Worksheet: Set lnksSht = ThisWorkbook.Sheets(HT03_SHT_LINKS) + Dim nRow&: nRow = HT03_DEFAULT_FIRST_LINE + Do + Dim sID$: sID = lnksSht.Cells(nRow, S_L_TO_ID) + If sID = vbNullString Then _ + Exit Do + If sID = nDelete Then _ + lnksSht.Cells(nRow, S_L_TO_ID) = nSubstitute + nRow = nRow + 1 + Loop +End Function diff --git a/src/database/Declarations.bas b/src/database/Declarations.bas new file mode 100644 index 0000000..5a0f172 --- /dev/null +++ b/src/database/Declarations.bas @@ -0,0 +1,21 @@ +Attribute VB_Name = "Declarations" +Option Private Module +Option Explicit + +Public Const HELP_BOOKMARK = "HT03_EXCEL" +Public Const HELP_FILE_PATH = "\\fs1.concept.ru\Projects\10 \01 \-\! .docx" +Public Const VIEW_TEMPLATE_PATH = "\\fs1.concept.ru\Projects\10 \01 \-\ UI.xltm" + +Public Const CELL_STAT_BASE = "c_StatBase" + +' _LS_ Statistics structure for law links +Public Enum StatsStruct + S_LS_LINKS_TOTAL = 15 ' + S_LS_LINKS_TODO = 16 ' + S_LS_LINKS_TODOIN = 17 ' + S_LS_LINKS_DECL = 18 ' + S_LS_LINKS_DECLIN = 19 ' + S_LS_LINKS_FOUND = 20 ' + S_LS_LINKS_DEFIN = 21 ' + S_LS_LINKS_ASPECT = 22 ' +End Enum diff --git a/src/database/DevHelper.bas b/src/database/DevHelper.bas new file mode 100644 index 0000000..7d7aa98 --- /dev/null +++ b/src/database/DevHelper.bas @@ -0,0 +1,71 @@ +Attribute VB_Name = "DevHelper" +Option Explicit + +Public Const TEST_FOLDER = "testTemp" + +Public Function Dev_PrepareSkeleton() + ' Do nothing +End Function + +Public Sub Dev_ManualRunTest() + Dim sSuite$: sSuite = "s_Database" + Dim sTest$: sTest = "t_RenameLawFile" + 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_ActiveStateExporter": Set Dev_GetTestSuite = New s_ActiveStateExporter + Case "s_Database": Set Dev_GetTestSuite = New s_Database + Case "s_DatabaseManager": Set Dev_GetTestSuite = New s_DatabaseManager + Case "s_IteratorLaw": Set Dev_GetTestSuite = New s_IteratorLaw + Case "s_IteratorLinkAll": Set Dev_GetTestSuite = New s_IteratorLinkAll + End Select +End Function + +Public Function GetDummyData() As ItemLaw + Set GetDummyData = New ItemLaw + With GetDummyData + .gid_ = GenerateGID + .status_ = T_LAWS_FULL + .type_ = T_LAW_05_CODEX + .fileName_ = "fileName" & CStr(.gid_) & ".docx" + .title_ = "title_" + .typeTxt_ = "typeTxt_" + .creator_ = "creator_" + .date_ = "date_" + .number_ = "number_" + .header_ = "header_" + .attach_ = "attach_" + .isScoped_ = True + .isDummy_ = False + End With +End Function + +Public Function GenerateLinks(Optional nCount& = 0) As String() + Dim lnkCount&: lnkCount = nCount + If lnkCount = 0 Then _ + lnkCount = Int((19 * Rnd) + 1) + Dim linksData() As String + ReDim linksData(1 To lnkCount, LinkTransferStruct.[_First] To LinkTransferStruct.[_Last]) + + Dim nItem& + For nItem = 1 To lnkCount Step 1 + linksData(nItem, S_TL_DESTINATION_ID) = CStr(GenerateGID) + linksData(nItem, S_TL_DESTINATION_SUB) = GenerateSub + linksData(nItem, S_TL_SOURCE_SUB) = GenerateSub + Next nItem + + GenerateLinks = linksData +End Function + +Public Function GenerateGID() As Long + GenerateGID = Int(9999 * Rnd) + 1000000 +End Function + +Public Function GenerateSub() As String + GenerateSub = "sub_" & Int(Rnd * 100) +End Function + diff --git a/src/database/ItemMerge.cls b/src/database/ItemMerge.cls new file mode 100644 index 0000000..f511e5a --- /dev/null +++ b/src/database/ItemMerge.cls @@ -0,0 +1,13 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ItemMerge" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public delete_ As Long +Public substitute_ As Long diff --git a/src/database/Main.bas b/src/database/Main.bas new file mode 100644 index 0000000..691a59b --- /dev/null +++ b/src/database/Main.bas @@ -0,0 +1,237 @@ +Attribute VB_Name = "Main" +Option Explicit + +Public Const PRODUCT_VERSION = "1.3.0" +Public Const PRODUCT_NAME = "Concept-NPA" + +Public g_VersionTimer As Long + +Public Sub Auto_Open() + Dim sCmd$: sCmd = OfficeCommandLine + If VBA.InStr(1, sCmd, "/automation", vbTextCompare) <> 0 Then _ + Exit Sub + + g_VersionTimer = SetTimer(0, 0, CP_VERSION_MSG_DELAY, AddressOf OnVersionCheck) +End Sub + +Public Function OnVersionCheck(ByVal nHwnd As Long, ByVal uMsg As Long, ByVal nEvent As Long, ByVal nTime As Long) + Call KillTimer(0, g_VersionTimer) + Call VersionValidate(PRODUCT_NAME, PRODUCT_VERSION) +End Function + +Public Sub RunFindNextDoc() + Dim theDB As InfoDatabase: Set theDB = AccessDatabase + Dim iLink As IteratorLinkAll: Set iLink = theDB.FindUnresolvedLink + If iLink Is Nothing Then + Call UserInteraction.ShowMessage(IM_NEXTDOC_OK) + Exit Sub + End If + + Call OpenUnresolvedDocument(theDB.Data(iLink.SourceID).FileName) +End Sub + +Public Sub RunCreateDummy() + Dim gid&: gid = GetSelectedGID() + If gid = HT03_INVALID_GID Then _ + Exit Sub + + If CreateDummyFor(gid) Then _ + Call UserInteraction.ShowMessage(IM_DUMMY_OK) +End Sub + +Public Sub RunDeleteLaw() + Dim gid&: gid = GetSelectedGID() + If gid = HT03_INVALID_GID Then _ + Exit Sub + If Not UserInteraction.AskQuestion(QM_DELETE_LAW, gid) Then _ + Exit Sub + + Dim uiWrap As New API_XLWrapper: Call uiWrap.SetDocument(ThisWorkbook) + Call uiWrap.PauseUI + Call DeleteLaw(gid) + Call uiWrap.ResumeUI + + Call UserInteraction.ShowMessage(IM_DELETE_LAW_OK, gid) +End Sub + +Public Sub RunDeleteLinks() + Dim gid&: gid = GetSelectedGID() + If gid = HT03_INVALID_GID Then _ + Exit Sub + If Not UserInteraction.AskQuestion(QM_DELETE_LINKS, gid) Then _ + Exit Sub + + Dim uiWrap As New API_XLWrapper: Call uiWrap.SetDocument(ThisWorkbook) + Call uiWrap.PauseUI + Dim nDeleted&: nDeleted = DeleteLinks(gid) + Call uiWrap.ResumeUI + + Call UserInteraction.ShowMessage(IM_DELETE_LINKS_OK, gid, nDeleted) +End Sub + +Public Sub RunMergeDocument() + Dim theDB As InfoDatabase: Set theDB = AccessDatabase + Dim iMerge As ItemMerge: Set iMerge = PromptMerge(theDB) + If iMerge Is Nothing Then _ + Exit Sub + If Not UserInteraction.AskQuestion(QM_MERGE_WARNING) Then _ + Exit Sub + + Dim uiWrap As New API_XLWrapper: Call uiWrap.SetDocument(ThisWorkbook) + Call uiWrap.PauseUI + + Call DeleteLaw(iMerge.delete_) + + Call CSE_ProgressBar.Init(" ", maxVal:=theDB.Count) + Call CSE_ProgressBar.ShowModeless + + Call ExecuteMerge(iMerge) + + Call Unload(CSE_ProgressBar) + Call uiWrap.ResumeUI + + Call UserInteraction.ShowMessage(IM_MERGE_OK, iMerge.delete_, iMerge.substitute_) +End Sub + +Public Sub RunOpenGarant() + Dim gid&: gid = GetSelectedGID() + If gid = HT03_INVALID_GID Then _ + Exit Sub + + Dim hLink As New ItemHyperlink: Call hLink.Init(DEFAULT_LINK_SYSTEM, gid) + Call UserInteraction.FollowHyperlink(ThisWorkbook, hLink.ToAddress) +End Sub + +Public Sub RunExportActive() +' Generate Excel file for Registry + Dim xlApp As New API_XLWrapper + Call xlApp.SetApplication(ThisWorkbook.Parent) + Dim outWB As Excel.Workbook: Set outWB = xlApp.NewDocument + If outWB Is Nothing Then + Call UserInteraction.ShowMessage(EM_XLOUT_CREATE_FAIL) + Exit Sub + End If + + Dim theDB As InfoDatabase: Set theDB = AccessDatabase + Call CSE_ProgressBar.Init(" ", maxVal:=theDB.Count + theDB.CountLinks) + Call CSE_ProgressBar.InitSecondBar(maxVal:=theDB.Count) + CSE_ProgressBar.Description = " " + Call CSE_ProgressBar.ShowModeless + + Call xlApp.PauseUI + Call Output2Excel(outWB, theDB) + Call xlApp.ResumeUI + + Call Unload(CSE_ProgressBar) + + Call ThisWorkbook.Sheets(HT03_SHT_INFO).Copy(After:=outWB.Sheets(2)) + Call outWB.Sheets(1).Activate + + Call UserInteraction.ShowMessage(IM_XLOUT_OK) +End Sub + +Public Sub RunStatistic() + Dim theDB As InfoDatabase: Set theDB = AccessDatabase + Dim uiWrap As New API_XLWrapper: Call uiWrap.SetDocument(ThisWorkbook) + Call uiWrap.PauseUI + + Call CSE_ProgressBar.Init(" ", sHeader:=" ...", maxVal:=theDB.Count) + Call CSE_ProgressBar.ShowModeless + Call UpdateStats(theDB) + Call Unload(CSE_ProgressBar) + + Call uiWrap.ResumeUI + + Call UserInteraction.ShowMessage(IM_STATS_OK) +End Sub + +Public Sub RunCreateView() + Dim xlWrap As New API_XLWrapper: Call xlWrap.SetApplication(ThisWorkbook.Application) + Dim newUI As Excel.Workbook: Set newUI = xlWrap.NewDocument(VIEW_TEMPLATE_PATH, bDefaultIfFail:=False) + If newUI Is Nothing Then _ + Exit Sub + + Call newUI.Activate + Call xlWrap.Run("SetDB", ThisWorkbook.FullName) +End Sub + +Public Sub RunUpdateFirstLink() + Dim uiWrap As New API_XLWrapper: Call uiWrap.SetDocument(ThisWorkbook) + Call uiWrap.PauseUI + + Dim theDB As InfoDatabase: Set theDB = AccessDatabase + Call CSE_ProgressBar.Init(" ", maxVal:=theDB.CountLinks) + Call CSE_ProgressBar.ShowModeless + Dim sMsg$: sMsg = theDB.ValidateLinks + Call Unload(CSE_ProgressBar) + + Call uiWrap.ResumeUI + + If sMsg = vbNullString Then + Call UserInteraction.ShowMessage(IM_RECREATE_OK) + Else + Call UIShowMessage(EM_LINKBASE_FAILED, sMsg) + End If +End Sub + +Public Sub RunRename() + Dim gid&: gid = GetSelectedGID() + If gid = HT03_INVALID_GID Then _ + Exit Sub + + Dim theDB As InfoDatabase: Set theDB = AccessDatabase + Dim sName$: sName = PromptNewFileName(gid, theDB) + If sName = vbNullString Then _ + Exit Sub + + If Not theDB.RenameLawFile(gid, sName) Then + Call UserInteraction.ShowMessage(EM_RENAME_FAILED, gid, sName) + Else + Call UserInteraction.ShowMessage(IM_RENAME_COMPLETE, gid, sName) + End If +End Sub + +Public Sub RunHyperlinks() + Call UpdateHyperlinks(Sheets(HT03_SHT_DOCS), AccessDatabase) + Call UserInteraction.ShowMessage(IM_HYPERLINKS_OK) +End Sub + +Public Sub RunUnstuck() + Dim uiWrap As New API_XLWrapper: Call uiWrap.SetDocument(ThisWorkbook) + Call uiWrap.ResumeUI + Call UserInteraction.ShowMessage(IM_UNSTUCK_OK) +End Sub + +Public Sub RunHelp() + Dim wordWrap As New API_WordWrapper + Dim helpDoc As Word.Document: Set helpDoc = wordWrap.OpenDocument(HELP_FILE_PATH, bReadOnly:=True) + If helpDoc Is Nothing Then _ + Exit Sub + With helpDoc + .Application.ActiveWindow.View.ReadingLayout = False + Call .ActiveWindow.ScrollIntoView(helpDoc.Bookmarks(HELP_BOOKMARK).Range) + Call .Application.Activate + End With +End Sub + +' ==== +Private Function GetSelectedGID() As Long + GetSelectedGID = HT03_INVALID_GID + Dim sel As Excel.Range: Set sel = Excel.Selection + Dim docsSht As Excel.Worksheet: Set docsSht = Sheets(HT03_SHT_DOCS) + + Dim selTxt$: selTxt = sel.Cells(1, 1) + If IsNumeric(selTxt) And ActiveSheet.Name <> docsSht.Name Then + GetSelectedGID = CLng(selTxt) + Exit Function + End If + + Dim gid&: gid = CLng(docsSht.Cells(sel.Cells(1, 1).Row, 1)) + If ActiveSheet.Name <> docsSht.Name Or sel.Rows.Count > 1 Or gid = 0 Then + Dim resStr$: resStr = UserInteraction.PromptInput(" ID ") + If resStr = vbNullString Or Not IsNumeric(resStr) Then _ + Exit Function + gid = CLng(resStr) + End If + GetSelectedGID = gid +End Function diff --git a/src/database/MainImpl.bas b/src/database/MainImpl.bas new file mode 100644 index 0000000..bf33dc9 --- /dev/null +++ b/src/database/MainImpl.bas @@ -0,0 +1,231 @@ +Attribute VB_Name = "MainImpl" +Option Private Module +Option Explicit + +Public Function Output2Excel(outWB As Excel.Workbook, theDB As InfoDatabase) + Dim exporter As New ActiveStateExporter: Call exporter.Init(outWB, theDB) + + Dim lawIDs As New Scripting.Dictionary + Set lawIDs = exporter.ExportLaws() + + Call CSE_ProgressBar.InitSecondBar(maxVal:=theDB.CountLinks) + CSE_ProgressBar.Description = " " + + Call exporter.ExportLinks(lawIDs) +End Function + +Public Function UpdateHyperlinks(target As Excel.Worksheet, theDB As InfoDatabase) + Dim nRow&: nRow = HT03_DEFAULT_FIRST_LINE + Do While target.Cells(nRow, 1) <> vbNullString + Dim aCell As Excel.Range: Set aCell = target.Cells(nRow, LawStruct.S_D_FILENAME) + Dim sFileName$: sFileName = aCell + + Call aCell.Hyperlinks.Delete + If sFileName <> vbNullString And sFileName <> HT03_FILE_NOT_LOADED Then _ + Call aCell.Hyperlinks.Add(aCell, theDB.DocumentsRelativePath & sFileName) + + nRow = nRow + 1 + Loop +End Function + +Public Function UpdateStats(theDB As InfoDatabase) + Dim outerDocs As New Collection + + Dim countDoc&, countLnk&, lnkTotal&, lnkProc&, lnkDeclined& + Dim lnkDeclinedIn&, lnkDefin&, lnkFound&, lnkAspekt&, lnkNotProcIn& + + Dim iLaw As IteratorLaw: Set iLaw = theDB.Laws + Do While Not iLaw.IsDone + lnkTotal = 0: lnkDeclined = 0: lnkDefin = 0: lnkAspekt = 0 + lnkProc = 0: lnkDeclinedIn = 0: lnkFound = 0: lnkNotProcIn = 0 + + If iLaw.Status = T_LAWS_IGNORE Then + Call SafeAddToCollection(VBA.CStr(iLaw.ID), VBA.CStr(iLaw.ID), outerDocs) + GoTo NEXT_DOC + End If + + Dim iLink As IteratorLinkLaw: Set iLink = iLaw.Links + If iLink Is Nothing Then _ + GoTo NEXT_DOC + + Do While iLink.Increment + lnkTotal = lnkTotal + 1 + If Not theDB.Contains(iLink.DestinationID) Then + Call SafeAddToCollection(VBA.CStr(iLink.DestinationID), VBA.CStr(iLink.DestinationID), outerDocs) + If iLink.IsProcessed Then + lnkProc = lnkProc + 1 + lnkDeclined = lnkDeclined + 1 + End If + Else + Dim isInner As Boolean: isInner = theDB.GetLawStatus(iLink.DestinationID) = T_LAWS_IGNORE + If Not iLink.IsProcessed Then + If isInner Then lnkNotProcIn = lnkNotProcIn + 1 + Else + lnkProc = lnkProc + 1 + If Not iLink.IsActive Then + lnkDeclined = lnkDeclined + 1 + If isInner Then lnkDeclinedIn = lnkDeclinedIn + 1 + Else + If iLink.LType = T_LINK_ASPECT Then lnkAspekt = lnkAspekt + 1 + If iLink.LType = T_LINK_DEFINITION Then lnkDefin = lnkDefin + 1 + If iLink.LType = T_LINK_FOUNDATION Then lnkFound = lnkFound + 1 + End If + End If + End If +NEXT_LINK: + Loop +NEXT_DOC: + With iLaw + Call .SetVaueIn(S_LS_LINKS_TOTAL, lnkTotal) + Call .SetVaueIn(S_LS_LINKS_TODO, lnkTotal - lnkProc) + Call .SetVaueIn(S_LS_LINKS_TODOIN, lnkNotProcIn) + Call .SetVaueIn(S_LS_LINKS_DECL, lnkDeclined) + Call .SetVaueIn(S_LS_LINKS_DECLIN, lnkDeclinedIn) + Call .SetVaueIn(S_LS_LINKS_ASPECT, lnkAspekt) + Call .SetVaueIn(S_LS_LINKS_FOUND, lnkFound) + Call .SetVaueIn(S_LS_LINKS_DEFIN, lnkDefin) + Call .Increment + End With + Call CSE_ProgressBar.IncrementA + CSE_ProgressBar.Description = iLaw.Title + Loop + + ThisWorkbook.Names(CELL_STAT_BASE).RefersToRange = outerDocs.Count + Call ThisWorkbook.Sheets(HT03_SHT_STATS).Calculate +End Function + +Public Function OpenUnresolvedDocument(sFileName$) As Boolean + OpenUnresolvedDocument = False + + Dim wordAppl As New API_WordWrapper + If wordAppl.OpenDocument(GetDocumentsLocation(ThisWorkbook) & "\" & sFileName) Is Nothing Then _ + Exit Function + + Call wordAppl.Document.Activate + wordAppl.Application.WindowState = xlMaximized + Call wordAppl.Run("HT03_UpdateMarkup") + Call wordAppl.Run("HT03_NextLink") + + Call AppActivate(wordAppl.Application.Caption) + + OpenUnresolvedDocument = True +End Function + +Public Function PromptNewFileName(target&, theDB As InfoDatabase) As String + Dim docData As IteratorLaw: Set docData = theDB.Data(target) + Dim oldName$: oldName = docData.FileName + If oldName = HT03_FILE_NOT_LOADED Then + Call UserInteraction.ShowMessage(EM_RENAME_UNLOADED) + Exit Function + End If + + oldName = VBA.Left(oldName, VBA.Len(oldName) - VBA.Len(HT03_DOC_EXTENSION)) + Dim newName$: newName = UserInteraction.PromptInput(" (80 )", " ", oldName) + If newName = vbNullString Or newName = oldName Then _ + Exit Function + + newName = SafeFileName(VBA.Trim(VBA.Left(newName, 80))) & HT03_DOC_EXTENSION + Dim theCopy As IteratorLaw: Set theCopy = theDB.FindByFileName(newName) + If Not theCopy Is Nothing Then + Call UserInteraction.ShowMessage(EM_NAME_TAKEN, theCopy.ID) + Exit Function + End If + + PromptNewFileName = newName +End Function + +Public Function CreateDummyFor(target&) As Boolean + CreateDummyFor = False + + Dim theDB As InfoDatabase: Set theDB = AccessDatabase + If Not theDB.Contains(target) Then + Call UserInteraction.ShowMessage(EM_MISSING_ID) + Exit Function + End If + + Dim iLaw As IteratorLaw: Set iLaw = theDB.Data(target) + If iLaw.HasFile Then + Call UserInteraction.ShowMessage(EM_DUMMY_HAS_FILE) + Exit Function + End If + + Dim iData As ItemLaw: Set iData = iLaw.Data + iData.fileName_ = theDB.GenerateFileName(iData.title_) + Call AddDummyDocument(iData, theDB.docsLocation_) + Call theDB.SetItem(iData) + + Dim sLinks() As String: ReDim sLinks(1 To 1, LinkTransferStruct.[_First] To LinkTransferStruct.[_Last]) + sLinks(1, S_TL_DESTINATION_ID) = CStr(target) + sLinks(1, S_TL_DESTINATION_SUB) = "sub_0" + sLinks(1, S_TL_SOURCE_SUB) = "sub_0" + Call theDB.SetLinksFor(target, sLinks) + + CreateDummyFor = True +End Function + +Public Function DeleteLaw(targetID&) + Dim removedCount&: removedCount = RemoveLinksFor(targetID) + Dim sFile$: sFile = RemoveIDFromDocs(targetID) + If sFile <> "" Then _ + Call KillDocument(sFile) + If removedCount <> 0 Then _ + Call AccessDatabase.ValidateLinks +End Function + +Public Function DeleteLinks(targetID&) As Long + DeleteLinks = RemoveLinksFor(targetID) + If DeleteLinks <> 0 Then _ + Call AccessDatabase.ValidateLinks +End Function + +Public Function PromptMerge(theDB As InfoDatabase) As ItemMerge + With MergeLawsDlg + Call .Init(theDB) + Call .Show + If .isCancelled_ Then _ + Exit Function + Set PromptMerge = .GetMerge + End With + Call Unload(MergeLawsDlg) +End Function + +Public Function ExecuteMerge(iMerge As ItemMerge) + Dim theDB As InfoDatabase: Set theDB = AccessDatabase + Dim sTitle$: sTitle = theDB.Data(iMerge.substitute_).Title + + Dim iWord As New API_WordWrapper: Call iWord.CreateApplication(bIsVisible:=True) + Dim iLaw As IteratorLaw: Set iLaw = theDB.Laws + Do While Not iLaw.IsDone + Dim iLink As IteratorLinkLaw: Set iLink = theDB.LawLinks(iLaw.ID) + If iLink Is Nothing Then _ + GoTo NEXT_LAW + + Do While iLink.Increment + If iLink.DestinationID = iMerge.delete_ Then + If Not iWord.OpenDocument(theDB.docsLocation_ & "\" & iLaw.FileName) Is Nothing Then + Call iWord.Document.Activate + Call iWord.Run("HT03_MergeID", iMerge.delete_, iMerge.substitute_, sTitle) + Call iWord.ReleaseDocument(bCloseApplication:=False, bSaveChanges:=True) + End If + GoTo NEXT_LAW + End If + Loop + +NEXT_LAW: + Call CSE_ProgressBar.IncrementA + Call iLaw.Increment + Loop + + Call iWord.ReleaseApplication + Call SubstituteLinks(iMerge.delete_, iMerge.substitute_) +End Function + +' ======== +Private Function KillDocument(targetFile$) + If targetFile = vbNullString Then _ + Exit Function + Dim fso As New Scripting.FileSystemObject + If fso.FileExists(targetFile) Then + Call Kill(targetFile) + End If +End Function diff --git a/src/database/ManualSubs.bas b/src/database/ManualSubs.bas new file mode 100644 index 0000000..5145042 --- /dev/null +++ b/src/database/ManualSubs.bas @@ -0,0 +1,108 @@ +Attribute VB_Name = "ManualSubs" +Option Private Module +Option Explicit + +Public Sub RunClearAll() + If UserInteraction.AskQuestion(QM_DELETE_SELF_CONFIRM) Then + Call ClearAll + Call UserInteraction.ShowMessage(IM_DELETE_LAW_OK) + End If +End Sub + +Public Sub UpdateParsedData() + Dim theDB As InfoDatabase: Set theDB = AccessDatabase + + Dim wordAppl As New API_WordWrapper + Call wordAppl.CreateApplication(bIsVisible:=False) + + Call CSE_ProgressBar.Init(" ", maxVal:=theDB.Count - 1, canInterrupt:=True) + Call CSE_ProgressBar.Show + + Dim uiWrap As New API_XLWrapper: Call uiWrap.SetDocument(ThisWorkbook) + Call uiWrap.PauseUI + + Dim iLaw As IteratorLaw: Set iLaw = theDB.Laws + Do While Not iLaw.IsDone + If CSE_ProgressBar.Interrupted Then _ + GoTo EXIT_LOOP + + CSE_ProgressBar.DescriptionTB = iLaw.FileName + If iLaw.FileName <> HT03_FILE_NOT_LOADED And iLaw.HasInfoBlanks Then _ + Call UpdateParsedDataFor(iLaw, wordAppl) + + Call iLaw.Increment + Call CSE_ProgressBar.IncrementA + Loop + +EXIT_LOOP: + Call uiWrap.ResumeUI + Call Unload(CSE_ProgressBar) + Call wordAppl.ReleaseApplication +End Sub + +Public Sub ParseTitles() + Dim theDB As InfoDatabase: Set theDB = AccessDatabase + + Call CSE_ProgressBar.Init(" ", maxVal:=theDB.Count - 1, canInterrupt:=True) + Call CSE_ProgressBar.Show + + Dim uiWrap As New API_XLWrapper: Call uiWrap.SetDocument(ThisWorkbook) + Call uiWrap.PauseUI + + Dim iLaw As IteratorLaw: Set iLaw = theDB.Laws + Do While Not iLaw.IsDone + If CSE_ProgressBar.Interrupted Then _ + GoTo EXIT_LOOP + + CSE_ProgressBar.DescriptionTB = iLaw.Title + Call UpdateParsedTitle(iLaw, iLaw.Title) + + Call iLaw.Increment + Call CSE_ProgressBar.IncrementA + Loop + +EXIT_LOOP: + Call uiWrap.ResumeUI + Call Unload(CSE_ProgressBar) +End Sub + +' ============ +Private Function UpdateParsedDataFor(target As IteratorLaw, wordAppl As API_WordWrapper) + If wordAppl.OpenDocument(GetDocumentsLocation(ThisWorkbook) & "\" & target.FileName, bReadOnly:=True) Is Nothing Then _ + Exit Function + + Dim sTitle$: sTitle = wordAppl.Document.Paragraphs(1).Range.Text + target.IsDummy = CheckIfDummy(wordAppl.Document) + + Call UpdateParsedTitle(target, sTitle) + +SAFE_EXIT: + Call wordAppl.ReleaseDocument(bCloseApplication:=False) +End Function + +Private Function UpdateParsedTitle(target As IteratorLaw, sTitle$) + Dim theData As ItemLaw: Set theData = ParseLawTitle(sTitle) + If theData Is Nothing Then _ + Exit Function + + If target.TypeText = vbNullString Then _ + target.TypeText = theData.typeTxt_ + If target.Creator = vbNullString Then _ + target.Creator = theData.creator_ + If target.CreationDate = vbNullString Then _ + target.CreationDate = theData.date_ + If target.Number = vbNullString Then _ + target.Number = theData.number_ + If target.Header = vbNullString Then _ + target.Header = theData.header_ + If target.Attachment = vbNullString Then _ + target.Attachment = theData.attach_ + target.IsScoped = theData.isScoped_ +End Function + +Private Function CheckIfDummy(target As Word.Document) As Boolean + With target.Range.Find + .Text = HT03_DUMMY_DOCUMENT_DISCLAIMER + CheckIfDummy = .Execute + End With +End Function diff --git a/src/database/MergeLawsDlg.frm b/src/database/MergeLawsDlg.frm new file mode 100644 index 0000000..7a93d1d --- /dev/null +++ b/src/database/MergeLawsDlg.frm @@ -0,0 +1,87 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} MergeLawsDlg + Caption = " " + ClientHeight = 3480 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 10695 + OleObjectBlob = "MergeLawsDlg.frx":0000 + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "MergeLawsDlg" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Explicit + +Public isCancelled_ As Boolean + +Private database_ As InfoDatabase + +Private Sub UserForm_Initialize() + isCancelled_ = True + Call PositionInMiddle(Me) +End Sub + +Public Function Init(theDB As InfoDatabase) + isCancelled_ = True + Set database_ = theDB +End Function + +Public Function GetMerge() As ItemMerge + Set GetMerge = New ItemMerge + With GetMerge + .delete_ = tbDocument1.Value + .substitute_ = tbDocument2.Value + End With +End Function + +' ============ +Private Sub btnValidate1_Click() + Dim iLaw As IteratorLaw: Set iLaw = ValidateGid(tbDocument1.Value) + If iLaw Is Nothing Then + tbTitle1.Text = " " + Else + tbTitle1.Text = iLaw.Title + End If +End Sub + +Private Sub btnValidate2_Click() + Dim iLaw As IteratorLaw: Set iLaw = ValidateGid(tbDocument2.Value) + If iLaw Is Nothing Then + tbTitle2.Text = " " + Else + tbTitle2.Text = iLaw.Title + End If +End Sub + +Private Sub btnCancel_Click() + isCancelled_ = True + Call Me.Hide +End Sub + +Private Sub btnOK_Click() + Dim sGid1$: sGid1 = tbDocument1.Value + Dim sGid2$: sGid2 = tbDocument2.Value + If sGid1 = sGid2 Or ValidateGid(sGid1) Is Nothing Or ValidateGid(sGid2) Is Nothing Then + Call UserInteraction.ShowMessage(EM_MERGE_VALIDATION_FAILED) + Exit Sub + End If + isCancelled_ = False + Call Me.Hide +End Sub + +' ============ +Private Function ValidateGid(sGid$) As IteratorLaw + If Not IsNumeric(sGid) Then + Call UserInteraction.ShowMessage(EM_ID_INVALID_FORMAT) + Exit Function + End If + + Dim gid&: gid = CLng(sGid) + If Not database_.Contains(gid) Then _ + Exit Function + + Set ValidateGid = database_.Data(gid) +End Function diff --git a/src/database/MergeLawsDlg.frx b/src/database/MergeLawsDlg.frx new file mode 100644 index 0000000..589ae06 Binary files /dev/null and b/src/database/MergeLawsDlg.frx differ diff --git a/src/database/z_UIMessages.bas b/src/database/z_UIMessages.bas new file mode 100644 index 0000000..02d6f8b --- /dev/null +++ b/src/database/z_UIMessages.bas @@ -0,0 +1,98 @@ +Attribute VB_Name = "z_UIMessages" +' +Option Explicit + +Public Enum MsgCode + MSG_OK = 0 + + EM_XLOUT_CREATE_FAIL + EM_NAME_TAKEN + EM_RENAME_UNLOADED + EM_LINKBASE_FAILED + EM_MISSING_ID + EM_DUMMY_HAS_FILE + EM_RENAME_FAILED + EM_ID_INVALID_FORMAT + EM_MERGE_VALIDATION_FAILED + + IM_XLOUT_OK + IM_STATS_OK + IM_NEXTDOC_OK + IM_UNSTUCK_OK + IM_RECREATE_OK + IM_DELETE_LAW_OK + IM_DELETE_LINKS_OK + IM_HYPERLINKS_OK + IM_RENAME_COMPLETE + IM_DUMMY_OK + IM_MERGE_OK + + QM_DELETE_LAW + QM_DELETE_SELF_CONFIRM + QM_DELETE_LINKS + QM_MERGE_WARNING +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_XLOUT_CREATE_FAIL: Call MsgBox(" ", vbExclamation) + Case EM_NAME_TAKEN: Call MsgBox(Fmt(" {1}", unwrapped), vbExclamation) + Case EM_RENAME_UNLOADED: Call MsgBox(" ", vbExclamation) + Case EM_LINKBASE_FAILED: Call MsgBox(Fmt(" :{1}", params), vbExclamation) + Case EM_MISSING_ID: Call MsgBox(" ", vbExclamation) + Case EM_DUMMY_HAS_FILE: Call MsgBox(" . ", vbExclamation) + Case EM_RENAME_FAILED: Call MsgBox(Fmt(" {1} {2}", unwrapped), vbExclamation) + Case EM_ID_INVALID_FORMAT: Call MsgBox(" ", vbExclamation) + Case EM_MERGE_VALIDATION_FAILED: Call MsgBox(" ID ", vbExclamation) + + Case IM_XLOUT_OK: Call MsgBox(" ", vbInformation) + Case IM_STATS_OK: Call MsgBox(" ", vbInformation) + Case IM_NEXTDOC_OK: Call MsgBox(" ", vbInformation) + Case IM_UNSTUCK_OK: Call MsgBox(" ", vbInformation) + Case IM_RECREATE_OK: Call MsgBox(" ", vbInformation) + Case IM_DELETE_LAW_OK: Call MsgBox(Fmt(", {1} ", unwrapped), vbInformation) + Case IM_DELETE_LINKS_OK: Call MsgBox(Fmt(" {1} . : {2}", unwrapped), vbInformation) + Case IM_HYPERLINKS_OK: Call MsgBox(" ", vbInformation) + Case IM_RENAME_COMPLETE: Call MsgBox(Fmt(" {1} : {2}", unwrapped), vbInformation) + Case IM_DELETE_LINKS_OK: Call MsgBox(Fmt(" {1} ", unwrapped), vbInformation) + Case IM_MERGE_OK: Call MsgBox(Fmt(" {1} -> {2}", unwrapped), vbInformation) + Case IM_DUMMY_OK: Call MsgBox("- " & vbNewLine & _ + "! , ", 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_DELETE_LAW: answer = MsgBox(Fmt("! {1} !" & vbNewLine & "?", unwrapped), vbYesNo + vbQuestion) + Case QM_DELETE_SELF_CONFIRM: answer = MsgBox(" ?", vbYesNo + vbQuestion) + Case QM_DELETE_LINKS: answer = MsgBox(Fmt("! {1} !" & vbNewLine & "?", unwrapped), vbYesNo + vbQuestion) + Case QM_MERGE_WARNING: answer = MsgBox("!! . " & _ + " . " & _ + " Word " & vbNewLine & _ + "?", vbYesNo + vbExclamation) + + Case Else: Call MsgBox(" ", vbCritical) + End Select + UIAskQuestion = answer = vbYes +End Function diff --git a/src/database/z_UIRibbon.bas b/src/database/z_UIRibbon.bas new file mode 100644 index 0000000..4ef59d2 --- /dev/null +++ b/src/database/z_UIRibbon.bas @@ -0,0 +1,23 @@ +Attribute VB_Name = "z_UIRibbon" +Option Explicit + +Public Sub OnRibbonBtn(iControl As IRibbonControl) + Select Case iControl.ID + Case "OpenGarant": Call RunOpenGarant + Case "DeleteDocument": Call RunDeleteLaw + Case "MergeDocument": Call RunMergeDocument + Case "DeleteLinks": Call RunDeleteLinks + Case "CreateDummy": Call RunCreateDummy + Case "RenameFile": Call RunRename + + Case "NextDoc": Call RunFindNextDoc + Case "Hyperlinks": Call RunHyperlinks + Case "Statistic": Call RunStatistic + Case "CreateView": Call RunCreateView + Case "PrepareOutput": Call RunExportActive + + Case "UpdateIndex": Call RunUpdateFirstLink + Case "Unstuck": Call RunUnstuck + Case "Help": Call RunHelp + End Select +End Sub diff --git a/src/test/s_ActiveStateExporter.cls b/src/test/s_ActiveStateExporter.cls new file mode 100644 index 0000000..ab64561 --- /dev/null +++ b/src/test/s_ActiveStateExporter.cls @@ -0,0 +1,128 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_ActiveStateExporter" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ===== Test suite for InfoDatabase ======= +Option Explicit + +Private db_ As InfoDatabase +Private xl_ As API_XLWrapper +Private out_ As Excel.Workbook +Private exporter_ As ActiveStateExporter + +Public Function Setup() + ' Mandatory setup function + Dim iPath As New API_Path: Call iPath.FromString(TEST_FOLDER).ToGlobal(ThisWorkbook.Path) + Set db_ = New InfoDatabase: Call db_.Init(ThisWorkbook, iPath.Text) + Set exporter_ = New ActiveStateExporter + Set xl_ = New API_XLWrapper: Call xl_.SetApplication(ThisWorkbook.Application) + Set out_ = xl_.NewDocument +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call xl_.ReleaseDocument + Call ClearAll +End Function + +Public Function t_Init() + On Error GoTo PROPAGATE_ERROR + + Call exporter_.Init(out_, db_) + Call Dev_ExpectEQ(2, out_.Sheets.Count, "Sheets count") + Call Dev_ExpectEQ("", out_.Sheets(1).Name, "Laws sheet") + Call Dev_ExpectEQ("ID", out_.Sheets(1).Cells(1, S_OD_ID), "Laws sheet") + Call Dev_ExpectEQ("", out_.Sheets(2).Name, "Links sheet") + Call Dev_ExpectEQ("Source", out_.Sheets(2).Cells(1, S_OL_SOURCE), "Links sheet") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ExportLaws() + On Error GoTo PROPAGATE_ERROR + + Call exporter_.Init(out_, db_) + + Call Dev_NewCase("Empty DB") + Dim iLaws As Scripting.Dictionary: Set iLaws = exporter_.ExportLaws + Call Dev_ExpectEQ(0, iLaws.Count) + Call Dev_ExpectEQ(vbNullString, out_.Sheets(1).Cells(2, S_OD_ID)) + + Call Dev_NewCase("Valid laws") + Dim item1 As New ItemLaw: Set item1 = GetDummyData + Dim item2 As New ItemLaw: Set item2 = GetDummyData + item2.gid_ = item1.gid_ + 1 + Call db_.SetItem(item1.Clone) + Call db_.SetItem(item2.Clone) + Set iLaws = exporter_.ExportLaws + + Call Dev_ExpectEQ(1, out_.Sheets(1).Cells(2, S_OD_ID)) + Call Dev_ExpectEQ(DefaultLawLevelFor(item1.type_), out_.Sheets(1).Cells(2, S_OD_LEVEL)) + Call Dev_ExpectEQ(item1.title_, out_.Sheets(1).Cells(2, S_OD_TITLE)) + Call Dev_ExpectEQ(item1.type_, out_.Sheets(1).Cells(2, S_OD_TYPE)) + Call Dev_ExpectEQ(item1.gid_, out_.Sheets(1).Cells(2, S_OD_GID)) + + Call Dev_ExpectEQ(2, out_.Sheets(1).Cells(3, S_OD_ID)) + Call Dev_ExpectEQ(DefaultLawLevelFor(item1.type_), out_.Sheets(1).Cells(3, S_OD_LEVEL)) + Call Dev_ExpectEQ(item2.title_, out_.Sheets(1).Cells(3, S_OD_TITLE)) + Call Dev_ExpectEQ(item2.type_, out_.Sheets(1).Cells(3, S_OD_TYPE)) + Call Dev_ExpectEQ(item2.gid_, out_.Sheets(1).Cells(3, S_OD_GID)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ExportLinks() + On Error GoTo PROPAGATE_ERROR + + Call exporter_.Init(out_, db_) + + Call Dev_NewCase("Empty DB") + Dim iLaws As Scripting.Dictionary: Set iLaws = exporter_.ExportLaws + Call exporter_.ExportLinks(iLaws) + Call Dev_ExpectEQ(vbNullString, out_.Sheets(2).Cells(2, S_OL_SOURCE)) + + Call Dev_NewCase("No links") + Dim item1 As New ItemLaw: Set item1 = GetDummyData + Dim item2 As New ItemLaw: Set item2 = GetDummyData + item2.gid_ = item1.gid_ + 1 + Call db_.SetItem(item1.Clone) + Call db_.SetItem(item2.Clone) + Set iLaws = exporter_.ExportLaws + Call exporter_.ExportLinks(iLaws) + Call Dev_ExpectEQ(vbNullString, out_.Sheets(2).Cells(2, S_OL_SOURCE)) + + Call Dev_NewCase("Self link") + Dim iLink As IteratorLinkAll: Set iLink = db_.Links + Call iLink.GotoInsertion + iLink.SourceID = item1.gid_ + iLink.DestinationID = item1.gid_ + Call exporter_.ExportLinks(iLaws) + Call Dev_ExpectEQ(vbNullString, out_.Sheets(2).Cells(2, S_OL_SOURCE)) + + Call Dev_NewCase("Valid link") + iLink.DestinationID = item2.gid_ + iLink.LType = T_LINK_ASPECT + iLink.Status = T_LINKS_ADD + Call exporter_.ExportLinks(iLaws) + Call Dev_ExpectEQ(1, out_.Sheets(2).Cells(2, S_OL_SOURCE)) + Call Dev_ExpectEQ(2, out_.Sheets(2).Cells(2, S_OL_TARGET)) + Call Dev_ExpectEQ(T_LINK_ASPECT, out_.Sheets(2).Cells(2, S_OL_TYPE)) + + Call Dev_NewCase("Invalid laws") + out_.Sheets(2).Cells(2, S_OL_SOURCE) = vbNullString + Call exporter_.ExportLinks(New Scripting.Dictionary) + Call Dev_ExpectEQ(vbNullString, out_.Sheets(2).Cells(2, S_OL_SOURCE)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_AddinAPI.cls b/src/test/s_AddinAPI.cls new file mode 100644 index 0000000..f491fa0 --- /dev/null +++ b/src/test/s_AddinAPI.cls @@ -0,0 +1,129 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_AddinAPI" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +' TODO: +' Public Function ProcessLawText(target As InfoDocument, theDB As InfoWordDatabase, props As ItemDocumentProperties) +' Public Function UpdateLinksIn(iDoc As InfoDocument, theDB As InfoDatabase) +' Public Function ToggleLinksStatusIn(target As Word.Range, iDoc As InfoDocument, theDB As InfoWordDatabase) +' Public Function IgnoreLawsIn(target As Word.Range, iDoc As InfoDocument, theDB As InfoDatabase) As Long +' Public Function RemoveLinksIn(iDoc As InfoDocument, target As Word.Range) + ' Range with only invalid links +' Public Function AddLinkTo(target As Word.Range, iLink As ItemLink, iDoc As InfoDocument, theDB As InfoWordDatabase) +' Public Function AddNewLaw(iDoc As InfoDocument, theDB As InfoWordDatabase, theProps As ItemDocumentProperties) + ' Check if folder doesnt exist + +Private fso_ As Scripting.FileSystemObject + +Private db_ As InfoWordDatabase +Private dbApp_ As API_XLWrapper + +Private wordApp_ As API_WordWrapper +Private iDoc_ As InfoDocument + +Public Function Setup() + ' Mandatory setup function + Set fso_ = New Scripting.FileSystemObject + On Error Resume Next + Call fso_.DeleteFolder(Dev_GetTestFolder) + On Error GoTo 0 + Call EnsureFolderExists(Dev_GetTestFolder & "\" & HT03_DEFAULT_WORKDIR) + + Set db_ = New InfoWordDatabase + Set dbApp_ = Dev_GetDatabase + Dim oDatabase As New InfoDatabase: Call oDatabase.Init(dbApp_.Document, Dev_GetTestFolder & "\" & HT03_DEFAULT_WORKDIR) + Call db_.Init(oDatabase) + + Set iDoc_ = New InfoDocument + Set wordApp_ = New API_WordWrapper + Call wordApp_.SetApplication(ThisDocument.Application) +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call wordApp_.ReleaseDocument + Call dbApp_.ReleaseDocument + Call fso_.DeleteFolder(Dev_GetTestFolder) +End Function + +Public Function t_PrepareNewLaw() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("New law") + Dim doc As Word.Document: Set doc = wordApp_.NewDocument + doc.Range.Text = "Title" + Set iDoc_.doc_ = doc + iDoc_.gid_ = 1337 + Dim iLaw As ItemLaw: Set iLaw = PrepareNewLaw(iDoc_, db_) + Call Dev_AssertNotNothing(iLaw) + Call Dev_ExpectEQ("Title", iLaw.title_) + Call Dev_ExpectEQ(iDoc_.gid_, iLaw.gid_) + Call Dev_ExpectEQ(T_LAWS_FULL, iLaw.status_) + Call Dev_ExpectFalse(iLaw.isDummy_) + Call Dev_ExpectEQ("0001 Title.docx", iLaw.fileName_) + + Call Dev_NewCase("Replace not loaded file") + Call iLaw.InitDummy(iLaw.gid_) + Call db_.source_.SetItem(iLaw.Clone) + Set iLaw = PrepareNewLaw(iDoc_, db_) + Call Dev_ExpectEQ("Title", iLaw.title_) + Call Dev_ExpectEQ(iDoc_.gid_, iLaw.gid_) + Call Dev_ExpectEQ(T_LAWS_FULL, iLaw.status_) + Call Dev_ExpectFalse(iLaw.isDummy_) + Call Dev_ExpectEQ("0001 Title.docx", iLaw.fileName_) + + Call Dev_NewCase("Already added") + Call db_.source_.SetItem(iLaw.Clone) + Call wordApp_.SaveAs(db_.source_.docsLocation_ & "\" & iLaw.fileName_) + Call Dev_MockUI.ExpectMessage(EM_FILE_ALREADY_ADDED) + Call Dev_ExpectNothing(PrepareNewLaw(iDoc_, db_)) + Call Dev_MockUI.ResetExpectations + + Call Dev_NewCase("Has existing dummy file") + Call wordApp_.SaveAs(Dev_GetTestFolder & "\" & doc.Name) + db_.source_.Data(iDoc_.gid_).IsDummy = True + db_.source_.Data(iDoc_.gid_).Status = T_LAWS_FRINGE + db_.source_.Data(iDoc_.gid_).DType = T_LAW_02_INTERNATIONAL + Call Dev_MockUI.ExpectQuestion(QM_DELETE_BEFORE_ADD_DUMMY, bAnswerYes:=True) + Set iLaw = PrepareNewLaw(iDoc_, db_) + Call Dev_AssertNotNothing(iLaw) + Call Dev_MockUI.ResetExpectations + Call Dev_ExpectEQ("Title", iLaw.title_) + Call Dev_ExpectEQ(iDoc_.gid_, iLaw.gid_) + Call Dev_ExpectFalse(iLaw.isDummy_) + Call Dev_ExpectEQ("0001 Title.docx", iLaw.fileName_) + Call Dev_ExpectEQ(T_LAWS_FRINGE, iLaw.status_) + Call Dev_ExpectEQ(T_LAW_02_INTERNATIONAL, iLaw.type_) + Call Dev_ExpectFalse(fso_.FileExists(db_.source_.docsLocation_ & "\" & iLaw.fileName_), "Delete previous file") + Call Dev_ExpectFalse(db_.source_.Contains(iDoc_.gid_), "Delete previous data entry") + + Call Dev_NewCase("Has existing non-dummy file") + Call db_.source_.SetItem(iLaw.Clone) + db_.source_.Data(iDoc_.gid_).Status = T_LAWS_FRINGE + db_.source_.Data(iDoc_.gid_).DType = T_LAW_02_INTERNATIONAL + Call wordApp_.SaveAs(db_.source_.docsLocation_ & "\" & iLaw.fileName_) + Call wordApp_.SaveAs(Dev_GetTestFolder & "\" & doc.Name) + Call Dev_MockUI.ExpectQuestion(QM_DELETE_BEFORE_ADD, bAnswerYes:=True) + Set iLaw = PrepareNewLaw(iDoc_, db_) + Call Dev_AssertNotNothing(iLaw) + Call Dev_MockUI.ResetExpectations + Call Dev_ExpectEQ("Title", iLaw.title_) + Call Dev_ExpectEQ(iDoc_.gid_, iLaw.gid_) + Call Dev_ExpectFalse(iLaw.isDummy_) + Call Dev_ExpectEQ("0001 Title.docx", iLaw.fileName_) + Call Dev_ExpectEQ(T_LAWS_FRINGE, iLaw.status_) + Call Dev_ExpectEQ(T_LAW_02_INTERNATIONAL, iLaw.type_) + Call Dev_ExpectFalse(fso_.FileExists(db_.source_.docsLocation_ & "\" & iLaw.fileName_), "Delete previous file") + Call Dev_ExpectFalse(db_.source_.Contains(iDoc_.gid_), "Delete previous data entry") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_DataImporter.cls b/src/test/s_DataImporter.cls new file mode 100644 index 0000000..e461b2b --- /dev/null +++ b/src/test/s_DataImporter.cls @@ -0,0 +1,40 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_DataImporter" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Test data importer ====== +Option Explicit + +' TODO: +' Public Function Init(dest As InfoDatabase, addTBA As Boolean) +' Public Function LoadDocs(ByRef iSource As IteratorLaw) +' Public Function LoadLinks(ByRef iSource As IteratorLinkAll) + +Private db_ As InfoDatabase + +Public Function Setup() + ' Mandatory setup function + Set db_ = New InfoDatabase +' Call db_.Init(ThisWorkbook, FixLocalPath(TEST_FOLDER, ThisWorkbook.Path)) +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call ClearData +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_Database.cls b/src/test/s_Database.cls new file mode 100644 index 0000000..7ae5761 --- /dev/null +++ b/src/test/s_Database.cls @@ -0,0 +1,689 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_Database" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ===== Test suite for InfoDatabase ======= +Option Explicit + +' Public Function FindUnresolvedLink() As IteratorLinkLaw + +Private db_ As InfoDatabase +Private fso_ As Scripting.FileSystemObject + +Public Function Setup() + ' Mandatory setup function + Set db_ = New InfoDatabase + Set fso_ = New Scripting.FileSystemObject + Dim iPath As New API_Path: Call iPath.FromString(TEST_FOLDER).ToGlobal(ThisWorkbook.Path) + Call db_.Init(ThisWorkbook, iPath.Text) + Call fso_.CreateFolder(db_.docsLocation_) +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call fso_.DeleteFolder(db_.docsLocation_) + Call ClearAll +End Function + +Public Function t_Loaded() + On Error GoTo PROPAGATE_ERROR + + Dim newDB As New InfoDatabase + Call Dev_ExpectFalse(newDB.Loaded, "Uninit db") + Call Dev_ExpectTrue(db_.Loaded, "Empty db") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_NeedUpdate() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectFalse(db_.NeedUpdate(), "No changes") + + ThisWorkbook.Sheets(HT03_SHT_DOCS).Cells(HT03_DEFAULT_FIRST_LINE, S_D_GARANT_ID) = "123" + Call Dev_ExpectTrue(db_.NeedUpdate(), "Change doc") + + ThisWorkbook.Sheets(HT03_SHT_DOCS).Cells(HT03_DEFAULT_FIRST_LINE, S_D_GARANT_ID) = "" + Call Dev_ExpectFalse(db_.NeedUpdate(), "Revert change") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_DocumentsLocation() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Uninitialized db") + Dim newDB As New InfoDatabase + On Error Resume Next + Call Dev_ExpectEQ("", newDB.docsLocation_) + Call Dev_ExpectNoError + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(ThisWorkbook.Path & "\" & HT03_DEFAULT_WORKDIR, AccessDatabase.docsLocation_, "Default folder") + Call Dev_ExpectEQ(ThisWorkbook.Path & "\" & TEST_FOLDER, db_.docsLocation_, "Custom folder") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_DocumentsRelativePath() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Uninitialized db") + Dim newDB As New InfoDatabase + On Error Resume Next + Call Dev_ExpectEQ("", newDB.DocumentsRelativePath) + Call Dev_ExpectAnyError + On Error GoTo PROPAGATE_ERROR + + Dim defaultDB As InfoDatabase: Set defaultDB = AccessDatabase + Call Dev_ExpectEQ(".\" & HT03_DEFAULT_WORKDIR & "\", defaultDB.DocumentsRelativePath, "Default folder") + Call Dev_ExpectEQ(".\" & TEST_FOLDER & "\", db_.DocumentsRelativePath, "Init folder") + + defaultDB.docsLocation_ = ThisWorkbook.Path + Call Dev_ExpectEQ(".\", defaultDB.DocumentsRelativePath, "Local folder") + + Dim sGlobal$: sGlobal = "D:\DEV\testLocation" + defaultDB.docsLocation_ = sGlobal + Call Dev_ExpectEQ(sGlobal & "\", defaultDB.DocumentsRelativePath, "Global folder") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_Validate() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty db") + Dim nEmptyHash$: nEmptyHash = db_.Hash + Call Dev_ExpectEQ(0, db_.Count) + Call Dev_ExpectFalse(db_.NeedUpdate) + + Call Dev_NewCase("Outdated db") + ThisWorkbook.Sheets(HT03_SHT_DOCS).Cells(HT03_DEFAULT_FIRST_LINE, S_D_GARANT_ID) = "123" + Call Dev_ExpectEQ(1, db_.Count) + Call Dev_ExpectTrue(db_.NeedUpdate) + + Call Dev_NewCase("Recreated db") + Call db_.Validate + Dim nNewHash$: nNewHash = db_.Hash + Call Dev_ExpectNE(nEmptyHash, nNewHash) + Call Dev_ExpectEQ(1, db_.Count) + Call Dev_ExpectFalse(db_.NeedUpdate) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_GenerateID() + On Error GoTo PROPAGATE_ERROR + + Dim emptyGid$: emptyGid = db_.GenerateID("") + Call Dev_ExpectNE(0, emptyGid, "Empty DB") + + Call Dev_NewCase("Seed taken") + Dim newData As New ItemLaw: Set newData = GetDummyData + newData.gid_ = emptyGid + Call db_.SetItem(newData.Clone) + Call Dev_ExpectNE(emptyGid, db_.GenerateID("")) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_SetItem() + On Error GoTo PROPAGATE_ERROR + + Dim newData As New ItemLaw: Set newData = GetDummyData + Call Dev_ExpectFalse(db_.Contains(newData.gid_), "Empty db contains nothing") + Call db_.SetItem(newData.Clone) + + Call Dev_NewCase("Add item to empty") + Call Dev_AssertEQ(1, db_.Count) + Call Dev_AssertTrue(db_.Contains(newData.gid_)) + Dim itLaw As IteratorLaw: Set itLaw = db_.Data(newData.gid_) + Call Dev_ExpectEQ(newData.gid_, itLaw.ID) + Call Dev_ExpectEQ(newData.status_, itLaw.Status) + Call Dev_ExpectEQ(newData.type_, itLaw.DType) + Call Dev_ExpectEQ(newData.fileName_, itLaw.FileName) + Call Dev_ExpectEQ(newData.title_, itLaw.Title) + Call Dev_ExpectEQ(newData.typeTxt_, itLaw.TypeText) + Call Dev_ExpectEQ(newData.creator_, itLaw.Creator) + Call Dev_ExpectEQ(newData.date_, itLaw.CreationDate) + Call Dev_ExpectEQ(newData.header_, itLaw.Header) + Call Dev_ExpectEQ(newData.attach_, itLaw.Attachment) + Call Dev_ExpectEQ(newData.isScoped_, itLaw.IsScoped) + Call Dev_ExpectEQ(newData.isDummy_, itLaw.IsDummy) + Call Dev_ExpectEQ(HT03_INVALID_ROW, itLaw.LinkBase) + Call Dev_ExpectEQ(newData.status_, db_.Cache(newData.gid_).status_) + + Call db_.SetItem(newData.Clone) + Call Dev_ExpectEQ(1, db_.Count, "Add item twice") + + newData.status_ = T_LAWS_FRINGE + Call db_.SetItem(newData.Clone) + Call Dev_ExpectEQ(1, db_.Count, "Update item") + Call Dev_ExpectEQ(newData.status_, db_.Data(newData.gid_).Status, "Update item data") + Call Dev_ExpectEQ(newData.status_, db_.Cache(newData.gid_).status_, "Update item cache") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_AddLinks() + On Error GoTo PROPAGATE_ERROR + + Dim unallocatedArray() As String + Dim docData As New ItemLaw: Set docData = GetDummyData + Dim gid&: gid = docData.gid_ + Call db_.SetItem(docData.Clone) + + Call Dev_ExpectFalse(db_.SetLinksFor(gid, unallocatedArray), "Unallocated array") + + Call Dev_NewCase("Valid add links") + Dim lnkData() As String: lnkData = GenerateLinks + Dim lnkCount&: lnkCount = UBound(lnkData, 1) - LBound(lnkData, 1) + 1 + Call Dev_AssertTrue(db_.SetLinksFor(gid, lnkData)) + + Dim itLnk As IteratorLinkLaw: Set itLnk = db_.LawLinks(gid) + Call Dev_AssertNotNothing(itLnk) + Call Dev_ExpectEQ(lnkCount, db_.CountLinks) + Dim nItem&: nItem = 0 + Do + nItem = nItem + 1 + Call Dev_ExpectEQ(lnkData(nItem, S_TL_DESTINATION_ID), CStr(itLnk.DestinationID)) + If Not itLnk.Increment Then _ + Exit Do + Loop + + Call Dev_NewCase("Reload links") + Dim lnkData2() As String: lnkData2 = GenerateLinks + lnkCount = UBound(lnkData2, 1) - LBound(lnkData2, 1) + 1 + Call Dev_AssertTrue(db_.SetLinksFor(gid, lnkData2)) + Call db_.Recreate + Call Dev_ExpectEQ(lnkCount, db_.CountLinks) + Set itLnk = db_.LawLinks(gid) + nItem = 0 + Do + nItem = nItem + 1 + Call Dev_ExpectEQ(lnkData2(nItem, S_TL_DESTINATION_ID), CStr(itLnk.DestinationID)) + If Not itLnk.Increment Then _ + Exit Do + Loop + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_HasLinksFor() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectFalse(db_.HasLinksFor(123), "Empty DB") + + Dim newData As New ItemLaw: Set newData = GetDummyData + Dim gid&: gid = newData.gid_ + Call db_.SetItem(newData.Clone) + Call Dev_ExpectFalse(db_.HasLinksFor(gid), "Has no links") + Call Dev_ExpectFalse(db_.HasLinksFor(gid + 1), "Invalid gid") + + Call db_.SetLinksFor(gid, GenerateLinks) + Call Dev_ExpectTrue(db_.HasLinksFor(gid), "Has links") + + Call Dev_NewCase("Corrupted link index") + Dim iLaw As IteratorLaw: Set iLaw = db_.Data(gid) + iLaw.LinkBase = HT03_INVALID_ROW + Call db_.Recreate + Call Dev_ExpectFalse(db_.HasLinksFor(gid)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_GetLawStatus() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(T_LAWS_NOTDEFINED, db_.GetLawStatus(123), "Empty DB") + + Dim newData As New ItemLaw: Set newData = GetDummyData + Dim gid&: gid = newData.gid_ + newData.status_ = T_LAWS_OUTER + Call db_.SetItem(newData.Clone) + Call Dev_ExpectEQ(T_LAWS_OUTER, db_.GetLawStatus(gid), "Valid status") + Call Dev_ExpectEQ(T_LAWS_NOTDEFINED, db_.GetLawStatus(gid + 1), "Invalid status") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_GetLawInfo() + On Error GoTo PROPAGATE_ERROR + + Dim iLaw As ItemLaw + Dim newData As New ItemLaw: Set newData = GetDummyData + Dim gid&: gid = newData.gid_ + + Call Dev_ExpectNothing(db_.GetLawInfo(123), "Empty DB") + + Call db_.SetItem(newData.Clone) + + Call Dev_ExpectNothing(db_.GetLawInfo(gid + 1), "Ivanlid ID") + + Call Dev_NewCase("Valid access") + Set iLaw = db_.GetLawInfo(gid) + Call Dev_AssertNotNothing(iLaw) + Call Dev_ExpectEQ(iLaw.attach_, newData.attach_) + Call Dev_ExpectEQ(iLaw.creator_, newData.creator_) + Call Dev_ExpectEQ(iLaw.date_, newData.date_) + Call Dev_ExpectEQ(iLaw.fileName_, newData.fileName_) + Call Dev_ExpectEQ(iLaw.gid_, newData.gid_) + Call Dev_ExpectEQ(iLaw.header_, newData.header_) + Call Dev_ExpectEQ(iLaw.isDummy_, newData.isDummy_) + Call Dev_ExpectEQ(iLaw.isScoped_, newData.isScoped_) + Call Dev_ExpectEQ(iLaw.number_, newData.number_) + Call Dev_ExpectEQ(iLaw.status_, newData.status_) + Call Dev_ExpectEQ(iLaw.title_, newData.title_) + Call Dev_ExpectEQ(iLaw.type_, newData.type_) + Call Dev_ExpectEQ(iLaw.typeTxt_, newData.typeTxt_) + + Call Dev_NewCase("Dummy") + newData.isDummy_ = True + Call db_.SetItem(newData.Clone) + Call Dev_ExpectNothing(db_.GetLawInfo(gid)) + + Call Dev_NewCase("Not loaded") + newData.isDummy_ = False + newData.title_ = HT03_TITLE_NOT_LOADED + Call db_.SetItem(newData.Clone) + Call Dev_ExpectNothing(db_.GetLawInfo(gid)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_FillLawsStatus() + On Error GoTo PROPAGATE_ERROR + + Dim docs As New Scripting.Dictionary + On Error Resume Next + Call db_.FillLawsStatus(docs) + Call Dev_ExpectNoError("Empty input") + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Valid input") + Dim newData As New ItemLaw: Set newData = GetDummyData + Dim gid&: gid = newData.gid_ + newData.status_ = T_LAWS_FRINGE + Call db_.SetItem(newData.Clone) + Call docs.Add(gid, "") + Call docs.Add(gid + 1, "") + Call db_.FillLawsStatus(docs) + Call Dev_ExpectEQ(T_LAWS_FRINGE, docs(gid)) + Call Dev_ExpectEQ(T_LAWS_NOTDEFINED, docs(gid + 1)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_FindByFileName() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectNothing(db_.FindByFileName("name.docx"), "Empty DB") + + Dim newData As New ItemLaw: Set newData = GetDummyData + Dim gid&: gid = newData.gid_ + Call db_.SetItem(newData.Clone) + + db_.Data(gid).FileName = "" + Call Dev_ExpectNothing(db_.FindByFileName(""), "Empty name") + + Call Dev_NewCase("Valid find by file name") + db_.Data(gid).FileName = newData.fileName_ + Dim it As IteratorLaw: Set it = db_.FindByFileName(newData.fileName_) + Call Dev_AssertNotNothing(it) + Call Dev_ExpectEQ(newData.gid_, it.ID) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_RenameLawFile() + On Error GoTo PROPAGATE_ERROR + + Dim newData As New ItemLaw: Set newData = GetDummyData + Dim gid&: gid = newData.gid_ + newData.fileName_ = "test001.txt" + Call db_.SetItem(newData.Clone) + Dim sAnotherName$: sAnotherName = "test002.txt" + Dim sFile1$: sFile1 = db_.docsLocation_ & "\" & newData.fileName_ + Dim sFile2$: sFile2 = db_.docsLocation_ & "\" & sAnotherName + + Call Dev_ExpectFalse(db_.RenameLawFile(gid, sAnotherName), "No file present") + + Dim fs As Scripting.TextStream: Set fs = fso_.CreateTextFile(sFile1) + Call fs.Close + + Call Dev_ExpectFalse(db_.RenameLawFile(gid, newData.fileName_), "Same name") + + Call Dev_NewCase("Valid rename") + Call Dev_ExpectTrue(db_.RenameLawFile(gid, sAnotherName), "Rename") + Call Dev_ExpectFalse(db_.NeedUpdate, "Need update") + Call Dev_ExpectEQ(sAnotherName, db_.Data(gid).FileName, "Check filename") + Call Dev_ExpectFalse(fso_.FileExists(sFile1), "Delete initial file") + Call Dev_ExpectTrue(fso_.FileExists(sFile2), "Renamed file exists") + + Call Dev_NewCase("Check hyperlink") + Dim fnCell As Excel.Range: Set fnCell = ThisWorkbook.Sheets(HT03_SHT_DOCS).Cells(db_.Data(gid).Row, S_D_FILENAME) + Call Dev_ExpectEQ(1, fnCell.Hyperlinks.Count) + Call Dev_ExpectEQ(TEST_FOLDER & "\" & sAnotherName, fnCell.Hyperlinks(1).Address) + + Call Dev_NewCase("Invalid filename") + Dim sInvalidName$: sInvalidName = "123?|.doc" + Dim sFile3$: sFile3 = db_.docsLocation_ & "\" & sInvalidName + Call Dev_ExpectFalse(db_.RenameLawFile(gid, sInvalidName)) + Call Dev_ExpectEQ(sAnotherName, db_.Data(gid).FileName) + + If fso_.FileExists(sFile1) Then _ + Call fso_.DeleteFile(sFile1) + If fso_.FileExists(sFile2) Then _ + Call fso_.DeleteFile(sFile2) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_IgnoreLaw() + On Error GoTo PROPAGATE_ERROR + + Dim newData As New ItemLaw: Set newData = GetDummyData + newData.status_ = T_LAWS_FRINGE + Dim gid&: gid = newData.gid_ + Dim externalGid&: externalGid = gid + 1 + Call db_.SetItem(newData.Clone) + Call db_.SetLinksFor(gid, GenerateLinks) + + Call Dev_NewCase("Ignore external document") + Call Dev_ExpectTrue(db_.IgnoreLaw(externalGid)) + Call Dev_AssertTrue(db_.Contains(externalGid)) + Call Dev_ExpectEQ(T_LAWS_IGNORE, db_.Data(externalGid).Status) + Call Dev_ExpectEQ(T_LAW_01_UNKNOWN, db_.Data(externalGid).DType) + Call Dev_ExpectEQ(HT03_FILE_NOT_LOADED, db_.Data(externalGid).FileName) + Call Dev_ExpectEQ(HT03_TITLE_NOT_LOADED, db_.Data(externalGid).Title) + Call Dev_ExpectTrue(db_.Data(externalGid).IsDummy) + + Call Dev_ExpectFalse(db_.IgnoreLaw(externalGid), "Ignore already ignored") + + Call Dev_NewCase("Ignore internal document") + Call Dev_ExpectTrue(db_.IgnoreLaw(gid)) + Call Dev_ExpectTrue(db_.Contains(gid)) + Call Dev_ExpectEQ(T_LAWS_IGNORE, db_.Data(gid).Status) + Call Dev_ExpectNE(0, db_.CountLinks, "Do not delete links on ignore") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_DeleteSomeLinksFor() + On Error GoTo PROPAGATE_ERROR + + Dim item1 As New ItemLaw: Set item1 = GetDummyData + Dim item2 As New ItemLaw: Set item2 = GetDummyData + item2.gid_ = item1.gid_ + 1 + + Call Dev_ExpectFalse(db_.DeleteSomeLinksFor(item1.gid_, 1, 1), "Remove links for invalid doc") + + Call db_.SetItem(item1.Clone) + Call db_.SetItem(item2.Clone) + + Call Dev_ExpectFalse(db_.DeleteSomeLinksFor(item1.gid_, 1, 1), "Remove links for doc with no links") + + Dim lnks() As String: lnks = GenerateLinks(50) + Call db_.SetLinksFor(item1.gid_, lnks) + Call db_.SetLinksFor(item2.gid_, GenerateLinks(10)) + + Call Dev_ExpectFalse(db_.DeleteSomeLinksFor(item1.gid_, 100, 1), "Remove links invalid start position") + Call Dev_ExpectFalse(db_.DeleteSomeLinksFor(item1.gid_, 1, 0), "Remove links zero count") + Call Dev_ExpectFalse(db_.DeleteSomeLinksFor(item1.gid_, 1, 100), "Remove links invalid count") + + Dim nLnk1&: nLnk1 = db_.Cache(item1.gid_).linkBase_ + Dim nLnk2&: nLnk2 = db_.Cache(item2.gid_).linkBase_ + + Call Dev_NewCase("Remove some links") + Dim delCount&: delCount = 10 + Call Dev_ExpectTrue(db_.DeleteSomeLinksFor(item1.gid_, 2, delCount)) + Call Dev_ExpectFalse(db_.NeedUpdate) + Call Dev_ExpectEQ(nLnk1, db_.Cache(item1.gid_).linkBase_) + Call Dev_ExpectEQ(nLnk2 - delCount, db_.Cache(item2.gid_).linkBase_) + Dim iLink As IteratorLinkLaw: Set iLink = db_.LawLinks(item1.gid_) + Call Dev_ExpectEQ(lnks(1, S_TL_DESTINATION_ID), CStr(iLink.DestinationID)) + Call iLink.Increment + Call Dev_ExpectEQ(lnks(12, S_TL_DESTINATION_ID), CStr(iLink.DestinationID)) + + Call Dev_NewCase("Remove all links") + delCount = ArraySize(lnks, 1) - delCount + Call Dev_ExpectTrue(db_.DeleteSomeLinksFor(item1.gid_, 1, delCount)) + Call Dev_ExpectFalse(db_.NeedUpdate) + Call Dev_ExpectEQ(HT03_INVALID_ROW, db_.Cache(item1.gid_).linkBase_) + Call Dev_ExpectEQ(nLnk1, db_.Cache(item2.gid_).linkBase_) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_DeleteLinksFor() + On Error GoTo PROPAGATE_ERROR + + Dim item1 As New ItemLaw: Set item1 = GetDummyData + Dim item2 As New ItemLaw: Set item2 = GetDummyData + item2.gid_ = item1.gid_ + 1 + Dim item3 As New ItemLaw: Set item3 = GetDummyData + item3.gid_ = item2.gid_ + 1 + + Call Dev_ExpectFalse(db_.DeleteLinksFor(item1.gid_), "Remove links for invalid doc") + + Call db_.SetItem(item1.Clone) + Call db_.SetItem(item2.Clone) + Call db_.SetItem(item3.Clone) + + Call Dev_ExpectFalse(db_.DeleteLinksFor(item1.gid_), "Remove links for doc with no links") + + Call db_.SetLinksFor(item1.gid_, GenerateLinks) + Call db_.SetLinksFor(item2.gid_, GenerateLinks) + Call db_.SetLinksFor(item3.gid_, GenerateLinks) + + Dim nLnk1&: nLnk1 = db_.Cache(item1.gid_).linkBase_ + Dim nLnk2&: nLnk2 = db_.Cache(item2.gid_).linkBase_ + Dim nLnk3&: nLnk3 = db_.Cache(item3.gid_).linkBase_ + + Call Dev_NewCase("Valid remove links") + Call Dev_ExpectTrue(db_.DeleteLinksFor(item2.gid_)) + Call Dev_ExpectFalse(db_.NeedUpdate) + Call Dev_ExpectEQ(nLnk1, db_.Cache(item1.gid_).linkBase_) + Call Dev_ExpectEQ(HT03_INVALID_ROW, db_.Cache(item2.gid_).linkBase_) + Call Dev_ExpectEQ(nLnk2, db_.Cache(item3.gid_).linkBase_) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_DeleteLaw() + On Error GoTo PROPAGATE_ERROR + + Dim item1 As New ItemLaw: Set item1 = GetDummyData + Dim item2 As New ItemLaw: Set item2 = GetDummyData + item2.gid_ = item1.gid_ + 1 + Dim item3 As New ItemLaw: Set item3 = GetDummyData + item3.gid_ = item2.gid_ + 1 + + Call Dev_ExpectFalse(db_.DeleteLaw(item1.gid_), "Delete invalid doc") + + Call Dev_NewCase("Delete document with no links") + Call db_.SetItem(item1.Clone) + Call Dev_ExpectTrue(db_.DeleteLaw(item1.gid_)) + Call Dev_ExpectFalse(db_.Contains(item1.gid_)) + Call Dev_ExpectFalse(db_.NeedUpdate) + + Call db_.SetItem(item1.Clone) + Call db_.SetItem(item2.Clone) + Call db_.SetItem(item3.Clone) + Call db_.SetLinksFor(item1.gid_, GenerateLinks) + Call db_.SetLinksFor(item2.gid_, GenerateLinks) + Call db_.SetLinksFor(item3.gid_, GenerateLinks) + + Dim nLnk1&: nLnk1 = db_.Cache(item1.gid_).linkBase_ + Dim nLnk2&: nLnk2 = db_.Cache(item2.gid_).linkBase_ + Dim nLnk3&: nLnk3 = db_.Cache(item3.gid_).linkBase_ + + Call Dev_NewCase("Valid delete document") + Call Dev_ExpectTrue(db_.DeleteLaw(item2.gid_)) + Call Dev_ExpectFalse(db_.Contains(item2.gid_)) + Call Dev_ExpectFalse(db_.NeedUpdate) + Call Dev_ExpectEQ(nLnk1, db_.Cache(item1.gid_).linkBase_) + Call Dev_ExpectEQ(nLnk2, db_.Cache(item3.gid_).linkBase_) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_AddLinkAfter() + On Error GoTo PROPAGATE_ERROR + + Dim item1 As New ItemLaw: Set item1 = GetDummyData + Dim item2 As New ItemLaw: Set item2 = GetDummyData + item2.gid_ = item1.gid_ + 1 + + Call Dev_ExpectFalse(db_.AddLinkAfter(item1.gid_, 0, 1, "", "", T_LINK_DEFAULT), "Add link to invalid doc") + + Call Dev_NewCase("Add link with invalid position") + Call db_.SetItem(item1.Clone) + Call db_.SetItem(item2.Clone) + Call Dev_ExpectFalse(db_.AddLinkAfter(item1.gid_, -1, item2.gid_, "", "", T_LINK_DEFAULT)) + Call Dev_ExpectFalse(db_.AddLinkAfter(item1.gid_, 10, item2.gid_, "", "", T_LINK_DEFAULT)) + + Call Dev_NewCase("Add link to empty doc") + Call Dev_ExpectTrue(db_.AddLinkAfter(item1.gid_, 0, item2.gid_, "subTo", "subFrom", T_LINK_DEFINITION)) + Call Dev_ExpectFalse(db_.NeedUpdate) + Call Dev_AssertNE(HT03_INVALID_ROW, db_.Cache(item1.gid_).linkBase_) + Call Dev_ExpectEQ(HT03_INVALID_ROW, db_.Cache(item2.gid_).linkBase_) + Call Dev_ExpectEQ(item2.gid_, db_.LawLinks(item1.gid_).DestinationID) + Call Dev_ExpectEQ("subTo", db_.LawLinks(item1.gid_).DestinationSub) + Call Dev_ExpectEQ("subFrom", db_.LawLinks(item1.gid_).SourceSub) + Call Dev_ExpectEQ(T_LINK_DEFINITION, db_.LawLinks(item1.gid_).LType) + + Dim lnks() As String: lnks = GenerateLinks(10) + Call db_.SetLinksFor(item1.gid_, lnks) + Call db_.SetLinksFor(item2.gid_, GenerateLinks(10)) + Dim nLnk1&: nLnk1 = db_.Cache(item1.gid_).linkBase_ + Dim nLnk2&: nLnk2 = db_.Cache(item2.gid_).linkBase_ + + Call Dev_NewCase("Add link to middle") + Call Dev_ExpectTrue(db_.AddLinkAfter(item1.gid_, 1, item2.gid_, "subTo", "subFrom", T_LINK_DEFINITION)) + Call Dev_ExpectFalse(db_.NeedUpdate) + Call Dev_AssertEQ(nLnk1, db_.Cache(item1.gid_).linkBase_) + Call Dev_ExpectEQ(nLnk2 + 1, db_.Cache(item2.gid_).linkBase_) + Dim iLink As IteratorLinkLaw: Set iLink = db_.LawLinks(item1.gid_) + Call Dev_ExpectEQ(lnks(1, S_TL_DESTINATION_ID), CStr(iLink.DestinationID)) + Call iLink.Increment + Call Dev_ExpectEQ(item2.gid_, iLink.DestinationID) + + Call Dev_NewCase("Add link last") + Call Dev_ExpectTrue(db_.AddLinkAfter(item1.gid_, ArraySize(lnks, 1) + 1, item2.gid_, "subTo", "subFrom", T_LINK_DEFINITION)) + Call Dev_ExpectFalse(db_.NeedUpdate) + Call Dev_ExpectEQ(nLnk1, db_.Cache(item1.gid_).linkBase_) + Call Dev_ExpectEQ(nLnk2 + 2, db_.Cache(item2.gid_).linkBase_) + Set iLink = db_.LawLinks(item1.gid_) + Call iLink.Increment(ArraySize(lnks, 1) + 1) + Call Dev_ExpectEQ(item2.gid_, iLink.DestinationID) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ValidateLinks() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(vbNullString, db_.ValidateLinks, "EmptyDB") + + Dim item1 As New ItemLaw: Set item1 = GetDummyData + Dim item2 As New ItemLaw: Set item2 = GetDummyData + item2.gid_ = item1.gid_ + 1 + + Call Dev_NewCase("No links") + Call db_.SetItem(item1.Clone) + Call db_.SetItem(item2.Clone) + Call Dev_ExpectEQ(vbNullString, db_.ValidateLinks) + + Call Dev_NewCase("Valid links") + Call db_.SetLinksFor(item1.gid_, GenerateLinks) + Call db_.SetLinksFor(item2.gid_, GenerateLinks) + Call Dev_ExpectEQ(vbNullString, db_.ValidateLinks) + + Call Dev_NewCase("Update invalid bases") + Dim nBase1&: nBase1 = db_.Cache(item1.gid_).linkBase_ + Dim nBase2&: nBase2 = db_.Cache(item2.gid_).linkBase_ + db_.Data(item1.gid_).LinkBase = HT03_INVALID_ROW + db_.Data(item2.gid_).LinkBase = HT03_INVALID_ROW + Call Dev_ExpectEQ(vbNullString, db_.ValidateLinks) + Call Dev_ExpectEQ(nBase1, db_.Cache(item1.gid_).linkBase_) + Call Dev_ExpectEQ(nBase1, db_.Data(item1.gid_).LinkBase) + Call Dev_ExpectEQ(nBase2, db_.Cache(item2.gid_).linkBase_) + Call Dev_ExpectEQ(nBase2, db_.Data(item2.gid_).LinkBase) + + Call Dev_NewCase("Update deleted links") + Call db_.DeleteLinksFor(item1.gid_) + nBase2 = db_.Cache(item2.gid_).linkBase_ + Call Dev_ExpectEQ(vbNullString, db_.ValidateLinks) + Call Dev_ExpectEQ(HT03_INVALID_ROW, db_.Cache(item1.gid_).linkBase_) + Call Dev_ExpectEQ(HT03_INVALID_ROW, db_.Data(item1.gid_).LinkBase) + Call Dev_ExpectEQ(nBase2, db_.Cache(item2.gid_).linkBase_) + Call Dev_ExpectEQ(nBase2, db_.Data(item2.gid_).LinkBase) + Call db_.SetLinksFor(item1.gid_, GenerateLinks) + + Call Dev_NewCase("Invalid document links") + Dim nInvalid&: nInvalid = item2.gid_ + 1 + Dim iLink As IteratorLinkAll: Set iLink = db_.Links + Call iLink.GotoInsertion + iLink.SourceID = nInvalid + iLink.DestinationID = item1.gid_ + iLink.Status = T_LINKS_ADD + iLink.LType = T_LINK_ASPECT + Dim sLog$: sLog = db_.ValidateLinks + Call Dev_ExpectNE(vbNullString, sLog) + Call Dev_ExpectTrue(InStr(1, sLog, CStr(nInvalid)) <> 0) + + Call Dev_NewCase("Duplicate document links") + iLink.SourceID = item2.gid_ + sLog = db_.ValidateLinks + Call Dev_ExpectNE(vbNullString, sLog) + Call Dev_ExpectTrue(InStr(1, sLog, CStr(item2.gid_)) <> 0) + Call iLink.RemoveRow + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_DatabaseManager.cls b/src/test/s_DatabaseManager.cls new file mode 100644 index 0000000..d51b199 --- /dev/null +++ b/src/test/s_DatabaseManager.cls @@ -0,0 +1,169 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_DatabaseManager" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Test data access ====== +Option Explicit + +' TODO: +' Public Function PromptNewFileName(target&, theDB As InfoDatabase) As String +' Public Function UpdateStats() +' Public Function Output2Excel(outWB As Excel.Workbook, theDB As InfoDatabase) +' Public Function UpdateHyperlinks(target As Excel.Worksheet) + +Private db_ As InfoDatabase + +Public Function Setup() + ' Mandatory setup function + Dim iPath As New API_Path: Call iPath.FromString(TEST_FOLDER).ToGlobal(ThisWorkbook.Path) + Set db_ = New InfoDatabase + Call db_.Init(ThisWorkbook, iPath.Text) +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call ClearAll +End Function + +Public Function t_ClearAll() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty DB") + On Error Resume Next + Call ClearAll + Call Dev_ExpectNoError + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Valid clear") + ThisWorkbook.Names(CELL_STAT_BASE).RefersToRange = 100 + Dim sDocs$: sDocs = GetDocumentsLocation(ThisWorkbook) + Call SetDocumentsLocation("test") + ThisWorkbook.Sheets(HT03_SHT_DOCS).Cells(2, 2) = "123" + ThisWorkbook.Sheets(HT03_SHT_LINKS).Cells(2, 2) = "123" + + Call ClearAll + Call Dev_ExpectEQ(0, ThisWorkbook.Names(CELL_STAT_BASE).RefersToRange.Value, "Stats") + Call Dev_ExpectEQ(sDocs, GetDocumentsLocation(ThisWorkbook), "4 location") + Call Dev_ExpectEQ("", ThisWorkbook.Sheets(HT03_SHT_DOCS).Cells(2, 2).Text, "Documents sheet") + Call Dev_ExpectEQ("", ThisWorkbook.Sheets(HT03_SHT_LINKS).Cells(2, 2).Text, "Links sheet") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_SetDocumentsLocation() + On Error GoTo PROPAGATE_ERROR + + Dim iPath As New API_Path: Call iPath.FromString(TEST_FOLDER).ToGlobal(ThisWorkbook.Path) + Dim defaultDB As InfoDatabase: Set defaultDB = AccessDatabase + Call Dev_ExpectEQ(GetDocumentsLocation(ThisWorkbook), defaultDB.docsLocation_, "Default location") + Call Dev_ExpectEQ(iPath.Text, db_.docsLocation_, "Init location") + + Call Dev_NewCase("Set empty location") + Call SetDocumentsLocation("") + Call Dev_ExpectFalse(defaultDB.NeedUpdate) + Call Dev_ExpectEQ(ThisWorkbook.Path, defaultDB.docsLocation_) + + Call Dev_NewCase("Set relative location") + Dim sLocal$: sLocal = "test1" + Call SetDocumentsLocation(sLocal) + Call iPath.FromString(sLocal).ToGlobal(ThisWorkbook.Path) + Call Dev_ExpectEQ(iPath.Text, defaultDB.docsLocation_) + + Call Dev_NewCase("Set absolute location") + Dim sGlobal$: sGlobal = "D:\DEV\testLocation" + Call SetDocumentsLocation(sGlobal) + Call Dev_ExpectEQ(sGlobal, defaultDB.docsLocation_) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_GetIndexDump() + On Error GoTo PROPAGATE_ERROR + + Dim resArr() As Long: resArr = GetIndexDump() + Call Dev_ExpectFalse(IsArrayAllocated(resArr), "Empty DB") + + Call Dev_NewCase("Valid index dump") + Dim item1 As ItemLaw: Set item1 = GetDummyData + Dim item2 As ItemLaw: Set item2 = GetDummyData + If item1.gid_ = item2.gid_ Then _ + item2.gid_ = item2.gid_ + 1 + item1.status_ = T_LAWS_IGNORE + item2.status_ = T_LAWS_FULL + item1.type_ = T_LAW_01_UNKNOWN + item2.type_ = T_LAW_04_FEDERAL_CONST + Call db_.SetItem(item1) + Call db_.SetItem(item2) + + resArr = GetIndexDump() + Call Dev_AssertTrue(IsArrayAllocated(resArr)) + Call Dev_AssertEQ(2, ArraySize(resArr, 1)) + Call Dev_AssertEQ(LawCacheStruct.[_Last], UBound(resArr, 2)) + Call Dev_AssertEQ(LawCacheStruct.[_First], LBound(resArr, 2)) + Call Dev_ExpectEQ(item1.gid_, resArr(1, S_CD_ID)) + Call Dev_ExpectEQ(item1.type_, resArr(1, S_CD_TYPE)) + Call Dev_ExpectEQ(item1.status_, resArr(1, S_CD_STATUS)) + Call Dev_ExpectEQ(item2.gid_, resArr(2, S_CD_ID)) + Call Dev_ExpectEQ(item2.type_, resArr(2, S_CD_TYPE)) + Call Dev_ExpectEQ(item2.status_, resArr(2, S_CD_STATUS)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_GetLinksDump() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectFalse(IsArrayAllocated(GetLinksDump(123)), "Empty DB") + + Dim item1 As ItemLaw: Set item1 = GetDummyData + Dim gid&: gid = item1.gid_ + Call db_.SetItem(item1) + Call Dev_ExpectFalse(IsArrayAllocated(GetLinksDump(gid + 1)), "Invalid ID") + Call Dev_ExpectFalse(IsArrayAllocated(GetLinksDump(gid)), "No links") + + Dim lnks() As String: lnks = GenerateLinks + Call db_.SetLinksFor(gid, lnks) + db_.LawLinks(gid).LType = T_LINK_ASPECT + db_.LawLinks(gid).Status = T_LINKS_IGNORE + + Call Dev_NewCase("Valid links dump") + Dim resArr() As Long: resArr = GetLinksDump(gid) + Call Dev_AssertTrue(IsArrayAllocated(resArr)) + Call Dev_AssertEQ(ArraySize(lnks, 1), ArraySize(resArr, 1)) + Call Dev_AssertEQ(LinkCacheStruct.[_Last], UBound(resArr, 2)) + Call Dev_AssertEQ(LinkCacheStruct.[_First], LBound(resArr, 2)) + Call Dev_ExpectEQ(db_.LawLinks(gid).DestinationID, resArr(1, S_CL_DESTINATION_ID)) + Call Dev_ExpectEQ(T_LINK_ASPECT, resArr(1, S_CL_TYPE)) + Call Dev_ExpectEQ(T_LINKS_IGNORE, resArr(1, S_CL_STATUS)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_SetLinksFor() + On Error GoTo PROPAGATE_ERROR + + Dim docData As New ItemLaw: Set docData = GetDummyData + Dim gid&: gid = docData.gid_ + Call db_.SetItem(docData) + + Dim lnks() As String: lnks = GenerateLinks + Call SetLinksFor(gid, lnks) + Call Dev_ExpectEQ(ArraySize(lnks, 1), db_.CountLinks, "Valid add links") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_DatabaseView.cls b/src/test/s_DatabaseView.cls new file mode 100644 index 0000000..fbb4c4f --- /dev/null +++ b/src/test/s_DatabaseView.cls @@ -0,0 +1,47 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_DatabaseView" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Test data view ====== +Option Explicit + +' TODO: +' Public Function AccessLocal() As InfoDatabase +' Public Function GetVisibleLaws() As Scripting.Dictionary +' Public Function GetSelectedLaws() As Scripting.Dictionary +' Public Function CreateGraph(Optional iFilter As Object = Nothing) As CDS_Graph +' Public Function SetDB(dbPath$) +' Public Function ImportData(iSource As InfoDatabase, iDestination As InfoDatabase) +' Public Function ClearData() +' Public Function ClearQueryDocs() +' Public Function ClearQueryLinks() +' Public Function ProposeNewDocument(target As Word.Document, theDB As InfoDatabase) As Boolean +' Public Function LoadTextsForLinks(iSource As InfoDatabase, iDestination As Excel.Worksheet) + +Private db_ As InfoDatabase + +Public Function Setup() + ' Mandatory setup function + Set db_ = New InfoDatabase + ' Call db_.Init(ThisWorkbook, FixLocalPath(TEST_FOLDER, ThisWorkbook.Path)) +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call ClearData +End Function + +Public Function t_SetDB() + On Error GoTo PROPAGATE_ERROR + + + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_DocumentProcessor.cls b/src/test/s_DocumentProcessor.cls new file mode 100644 index 0000000..ff7dba2 --- /dev/null +++ b/src/test/s_DocumentProcessor.cls @@ -0,0 +1,194 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_DocumentProcessor" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +' TODO: +' Public Function PrepareDocumentText(doc As Word.Document, iMods As ItemDocumentModification) + +Private wordApp_ As API_WordWrapper +Private doc_ As Word.Document + +Public Function Setup() + ' Mandatory setup function + Set wordApp_ = New API_WordWrapper + Call wordApp_.SetApplication(ThisDocument.Application) + Set doc_ = wordApp_.NewDocument +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call wordApp_.ReleaseDocument +End Function + +Public Function t_ParseHyperlink() + On Error GoTo PROPAGATE_ERROR + + Dim tRange As Word.Range: Set tRange = WordAddLine("test", doc_.Range) + Dim hLink As Word.Hyperlink + + Call Dev_NewCase("Invalid address") + Set hLink = tRange.Hyperlinks.Add(tRange, "invalid") + + Call Dev_ExpectNothing(ParseHyperlink(hLink)) + Call Dev_ExpectFalse(IsHyperlinkValid(hLink)) + + Call Dev_NewCase("Valid address") + Dim sAddress$: sAddress = "http://mobileonline.garant.ru/document/redirect/1337/2" + hLink.Address = "http://mobileonline.garant.ru/document/redirect/1337/2" + Call Dev_ExpectTrue(IsHyperlinkValid(hLink)) + Dim iLink As ItemHyperlink: Set iLink = ParseHyperlink(hLink) + Call Dev_ExpectEQ(PT_MOBILE, iLink.LinkSystem) + Call Dev_ExpectEQ(1337, iLink.DocumentID) + Call Dev_ExpectEQ("sub_2", iLink.BookmarkName) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_GetFirstValidHyperlinkIn() + On Error GoTo PROPAGATE_ERROR + + Dim rTargetArea As Word.Range + + Call WordAddLine("test1" & vbNewLine & "test2" & vbNewLine & "test3" & vbNewLine & "test4", doc_.Range) + Call Dev_ExpectNothing(GetFirstValidHyperlinkIn(doc_.Range), "No hyperlinks") + + Dim sAddress2$: sAddress2 = "garantf1://1337.0/" + Dim sAddress3$: sAddress3 = "garantf1://1338.12/" + Dim hLink1 As Word.Hyperlink: Set hLink1 = doc_.Hyperlinks.Add(doc_.Paragraphs(1).Range, "invalid") + Dim hLink2 As Word.Hyperlink: Set hLink2 = doc_.Hyperlinks.Add(doc_.Paragraphs(2).Range, sAddress2) + Dim hLink3 As Word.Hyperlink: Set hLink2 = doc_.Hyperlinks.Add(doc_.Paragraphs(3).Range, sAddress3) + + Call Dev_ExpectNothing(GetFirstValidHyperlinkIn(hLink1.Range), "Invalid address") + Call Dev_ExpectEQ(hLink2.Address, GetFirstValidHyperlinkIn(hLink2.Range).Address, "Full range of single link") + Call Dev_ExpectEQ(hLink2.Address, GetFirstValidHyperlinkIn(doc_.Range).Address, "Skip invalid link") + + Call Dev_NewCase("Partial hit") + Set rTargetArea = doc_.Range(hLink2.Range.Words.Last.Start, doc_.Range.End) + Call Dev_ExpectEQ(hLink2.Address, GetFirstValidHyperlinkIn(rTargetArea).Address, "Full range of single link") + + Call Dev_NewCase("Do no wrap") + Set rTargetArea = doc_.Range.Paragraphs(4).Range + Call Dev_ExpectNothing(GetFirstValidHyperlinkIn(rTargetArea)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ScanLawIDs() + On Error GoTo PROPAGATE_ERROR + + Call WordAddLine("test1" & vbNewLine & "test2" & vbNewLine & "test3" & vbNewLine & "test4", doc_.Range) + Call Dev_ExpectEQ(0, ScanLawIDs(doc_.Range).Count, "No hyperlinks") + + Call doc_.Hyperlinks.Add(doc_.Paragraphs(1).Range, "invalid123") + Call doc_.Hyperlinks.Add(doc_.Paragraphs(2).Range, "garantf1://1337.0/") + Call doc_.Hyperlinks.Add(doc_.Paragraphs(3).Range, "garantf1://1338.12/") + Call doc_.Hyperlinks.Add(doc_.Paragraphs(4).Range, "garantf1://1337.12/") + + Dim ids As New Scripting.Dictionary + Call ids.Add(1337, 0) + Call ids.Add(1338, 0) + + Call Dev_ExpectEQ(ids, ScanLawIDs(doc_.Range), "Scan multiple ids") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_GetLinkStatusStyle() + On Error GoTo PROPAGATE_ERROR + + ' ===== T_LAWS_NOTDEFINED + Call Dev_ExpectEQ(Style0A, GetLinkStatusStyle(T_LAWS_FULL, T_LAWS_NOTDEFINED, T_LINK_DEFAULT)) + Call Dev_ExpectEQ(Style0A, GetLinkStatusStyle(T_LAWS_FULL, T_LAWS_NOTDEFINED, T_LINK_ASPECT)) + Call Dev_ExpectEQ(Style0A, GetLinkStatusStyle(T_LAWS_FULL, T_LAWS_NOTDEFINED, T_LINK_FOUNDATION)) + Call Dev_ExpectEQ(Style0A, GetLinkStatusStyle(T_LAWS_FULL, T_LAWS_NOTDEFINED, T_LINK_DEFINITION)) + + Call Dev_ExpectEQ(Style4A, GetLinkStatusStyle(T_LAWS_FRINGE, T_LAWS_NOTDEFINED, T_LINK_DEFAULT)) + Call Dev_ExpectEQ(Style4A, GetLinkStatusStyle(T_LAWS_FRINGE, T_LAWS_NOTDEFINED, T_LINK_ASPECT)) + Call Dev_ExpectEQ(Style4A, GetLinkStatusStyle(T_LAWS_FRINGE, T_LAWS_NOTDEFINED, T_LINK_FOUNDATION)) + Call Dev_ExpectEQ(Style4A, GetLinkStatusStyle(T_LAWS_FRINGE, T_LAWS_NOTDEFINED, T_LINK_DEFINITION)) + + ' ====== T_LAWS_FULL + Call Dev_ExpectEQ(Style10, GetLinkStatusStyle(T_LAWS_FULL, T_LAWS_FULL, T_LINK_DEFAULT)) + Call Dev_ExpectEQ(Style11, GetLinkStatusStyle(T_LAWS_FULL, T_LAWS_FULL, T_LINK_ASPECT)) + Call Dev_ExpectEQ(Style12, GetLinkStatusStyle(T_LAWS_FULL, T_LAWS_FULL, T_LINK_FOUNDATION)) + Call Dev_ExpectEQ(Style13, GetLinkStatusStyle(T_LAWS_FULL, T_LAWS_FULL, T_LINK_DEFINITION)) + + Call Dev_ExpectEQ(Style10, GetLinkStatusStyle(T_LAWS_FRINGE, T_LAWS_FULL, T_LINK_DEFAULT)) + Call Dev_ExpectEQ(Style11, GetLinkStatusStyle(T_LAWS_FRINGE, T_LAWS_FULL, T_LINK_ASPECT)) + Call Dev_ExpectEQ(Style12, GetLinkStatusStyle(T_LAWS_FRINGE, T_LAWS_FULL, T_LINK_FOUNDATION)) + Call Dev_ExpectEQ(Style13, GetLinkStatusStyle(T_LAWS_FRINGE, T_LAWS_FULL, T_LINK_DEFINITION)) + + ' ====== T_LAWS_FRINGE + Call Dev_ExpectEQ(Style20, GetLinkStatusStyle(T_LAWS_FULL, T_LAWS_FRINGE, T_LINK_DEFAULT)) + Call Dev_ExpectEQ(Style21, GetLinkStatusStyle(T_LAWS_FULL, T_LAWS_FRINGE, T_LINK_ASPECT)) + Call Dev_ExpectEQ(Style22, GetLinkStatusStyle(T_LAWS_FULL, T_LAWS_FRINGE, T_LINK_FOUNDATION)) + Call Dev_ExpectEQ(Style23, GetLinkStatusStyle(T_LAWS_FULL, T_LAWS_FRINGE, T_LINK_DEFINITION)) + + Call Dev_ExpectEQ(Style20, GetLinkStatusStyle(T_LAWS_FRINGE, T_LAWS_FRINGE, T_LINK_DEFAULT)) + Call Dev_ExpectEQ(Style21, GetLinkStatusStyle(T_LAWS_FRINGE, T_LAWS_FRINGE, T_LINK_ASPECT)) + Call Dev_ExpectEQ(Style22, GetLinkStatusStyle(T_LAWS_FRINGE, T_LAWS_FRINGE, T_LINK_FOUNDATION)) + Call Dev_ExpectEQ(Style23, GetLinkStatusStyle(T_LAWS_FRINGE, T_LAWS_FRINGE, T_LINK_DEFINITION)) + + ' ====== T_LAWS_OUTER + Call Dev_ExpectEQ(Style30, GetLinkStatusStyle(T_LAWS_FULL, T_LAWS_OUTER, T_LINK_DEFAULT)) + Call Dev_ExpectEQ(Style31, GetLinkStatusStyle(T_LAWS_FULL, T_LAWS_OUTER, T_LINK_ASPECT)) + Call Dev_ExpectEQ(Style32, GetLinkStatusStyle(T_LAWS_FULL, T_LAWS_OUTER, T_LINK_FOUNDATION)) + Call Dev_ExpectEQ(Style33, GetLinkStatusStyle(T_LAWS_FULL, T_LAWS_OUTER, T_LINK_DEFINITION)) + + Call Dev_ExpectEQ(Style30, GetLinkStatusStyle(T_LAWS_FRINGE, T_LAWS_OUTER, T_LINK_DEFAULT)) + Call Dev_ExpectEQ(Style31, GetLinkStatusStyle(T_LAWS_FRINGE, T_LAWS_OUTER, T_LINK_ASPECT)) + Call Dev_ExpectEQ(Style32, GetLinkStatusStyle(T_LAWS_FRINGE, T_LAWS_OUTER, T_LINK_FOUNDATION)) + Call Dev_ExpectEQ(Style33, GetLinkStatusStyle(T_LAWS_FRINGE, T_LAWS_OUTER, T_LINK_DEFINITION)) + + ' ====== T_LAWS_IGNORE + Call Dev_ExpectEQ(Style4A, GetLinkStatusStyle(T_LAWS_FULL, T_LAWS_IGNORE, T_LINK_DEFAULT)) + Call Dev_ExpectEQ(Style4A, GetLinkStatusStyle(T_LAWS_FULL, T_LAWS_IGNORE, T_LINK_ASPECT)) + Call Dev_ExpectEQ(Style4A, GetLinkStatusStyle(T_LAWS_FULL, T_LAWS_IGNORE, T_LINK_FOUNDATION)) + Call Dev_ExpectEQ(Style4A, GetLinkStatusStyle(T_LAWS_FULL, T_LAWS_IGNORE, T_LINK_DEFINITION)) + + Call Dev_ExpectEQ(Style4A, GetLinkStatusStyle(T_LAWS_FRINGE, T_LAWS_IGNORE, T_LINK_DEFAULT)) + Call Dev_ExpectEQ(Style4A, GetLinkStatusStyle(T_LAWS_FRINGE, T_LAWS_IGNORE, T_LINK_ASPECT)) + Call Dev_ExpectEQ(Style4A, GetLinkStatusStyle(T_LAWS_FRINGE, T_LAWS_IGNORE, T_LINK_FOUNDATION)) + Call Dev_ExpectEQ(Style4A, GetLinkStatusStyle(T_LAWS_FRINGE, T_LAWS_IGNORE, T_LINK_DEFINITION)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CreateBookmarkFor() + On Error GoTo PROPAGATE_ERROR + + Call WordAddLine("test1" & vbNewLine & "test2" & vbNewLine & "test3" & vbNewLine & "test4", doc_.Range) + Dim hLink1 As Word.Hyperlink: Set hLink1 = doc_.Hyperlinks.Add(doc_.Paragraphs(1).Range, "invalid123") + Dim hLink2 As Word.Hyperlink: Set hLink2 = doc_.Hyperlinks.Add(doc_.Paragraphs(2).Range, "garantf1://1337.0/") + + Call Dev_NewCase("Invalid link") + Call Dev_ExpectEQ("lnk_1", CreateBookmarkFor(hLink1.Range)) + Call Dev_ExpectEQ(doc_.Bookmarks(1).Range.Text, hLink1.Range.Text) + + Call Dev_NewCase("Valid link") + Call Dev_ExpectEQ("lnk_2", CreateBookmarkFor(hLink2.Range)) + Call Dev_ExpectEQ(doc_.Bookmarks(2).Range.Text, hLink2.Range.Text) + + Call Dev_NewCase("BM already exists") + Call Dev_ExpectEQ("lnk_3", CreateBookmarkFor(hLink2.Range)) + Call Dev_ExpectEQ(doc_.Bookmarks(3).Range.Text, hLink2.Range.Text) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_InfoDocument.cls b/src/test/s_InfoDocument.cls new file mode 100644 index 0000000..e162e8a --- /dev/null +++ b/src/test/s_InfoDocument.cls @@ -0,0 +1,501 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_InfoDocument" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +' TODO: +' Public Function UpdateFormatFilter(docsFilter As Scripting.Dictionary, theDB As InfoDatabase) +' Public Function UpdateFormat(theDB As InfoDatabase) As Long + ' Check first link should not be formatted + +Private wordApp_ As API_WordWrapper +Private iDoc_ As InfoDocument +Private fso_ As Scripting.FileSystemObject + +Public Function Setup() + ' Mandatory setup function + Set iDoc_ = New InfoDocument + Set fso_ = New Scripting.FileSystemObject + + On Error Resume Next + Call fso_.DeleteFolder(Dev_GetTestFolder) + Call EnsureFolderExists(Dev_GetTestFolder) + + Set wordApp_ = New API_WordWrapper + Call wordApp_.SetApplication(ThisDocument.Application) +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call wordApp_.ReleaseDocument + Call fso_.DeleteFolder(Dev_GetTestFolder) +End Function + +Public Function t_Init() + On Error GoTo PROPAGATE_ERROR + + Dim doc As Word.Document: Set doc = wordApp_.NewDocument + + Call Dev_ExpectFalse(iDoc_.Init(doc), "Empty document") + + Call doc.Range.InsertAfter("test1" & vbNewLine) + Call doc.Range.InsertAfter("test2" & vbNewLine) + Call Dev_ExpectFalse(iDoc_.Init(doc), "No hyperlinks") + + Call Dev_NewCase("Second paragraph link") + Call doc.Hyperlinks.Add(doc.Paragraphs.Last.Range, "http://mobileonline.garant.ru/document/redirect/1337/0") + Call Dev_ExpectFalse(iDoc_.Init(doc)) + + Call Dev_NewCase("Mobile garant") + Call doc.Hyperlinks.Add(doc.Paragraphs.First.Range, "http://mobileonline.garant.ru/document/redirect/1337/0") + Call Dev_ExpectTrue(iDoc_.Init(doc)) + Call Dev_ExpectEQ(doc.Name, iDoc_.doc_.Name) + Call Dev_ExpectEQ(1337, iDoc_.gid_) + Call Dev_ExpectEQ(PT_MOBILE, iDoc_.linkSystem_) + + Call Dev_NewCase("Local garant") + doc.Hyperlinks(1).Address = "garantf1://1338.0/" + Set iDoc_ = New InfoDocument + Call Dev_ExpectTrue(iDoc_.Init(doc)) + Call Dev_ExpectEQ(doc.Name, iDoc_.doc_.Name) + Call Dev_ExpectEQ(1338, iDoc_.gid_) + Call Dev_ExpectEQ(PT_LOCAL, iDoc_.linkSystem_) + + Call Dev_NewCase("IVO garant") + doc.Hyperlinks(1).Address = "http://internet.garant.ru/document/redirect/1339/0" + Set iDoc_ = New InfoDocument + Call Dev_ExpectTrue(iDoc_.Init(doc)) + Call Dev_ExpectEQ(doc.Name, iDoc_.doc_.Name) + Call Dev_ExpectEQ(1339, iDoc_.gid_) + Call Dev_ExpectEQ(PT_INTERNET, iDoc_.linkSystem_) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_GetSelection() + On Error GoTo PROPAGATE_ERROR + + Dim doc As Word.Document: Set doc = wordApp_.NewDocument + Call doc.Range.InsertAfter("test1" & vbNewLine) + Set iDoc_.doc_ = doc + + Call Dev_ExpectEQ(vbNullString, iDoc_.GetSelection.Text, "Empty selection") + Call doc.Range.Words(1).Select + Call Dev_ExpectEQ(doc.Range.Words(1).Text, iDoc_.GetSelection.Text, "Empty selection") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_UpdateStyles() + On Error GoTo PROPAGATE_ERROR + + Set iDoc_.doc_ = wordApp_.NewDocument + Call iDoc_.UpdateStyles(ThisDocument.FullName) + Dim sStyle As Variant + For Each sStyle In GetAllLinkStyles() + Call Dev_ExpectTrue(WordStyleExists(iDoc_.doc_, CStr(sStyle)), "Test style " & sStyle) + Next sStyle + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CreateTitleLink() + On Error GoTo PROPAGATE_ERROR + + Dim doc As Word.Document: Set doc = wordApp_.NewDocument + Call doc.Range.InsertAfter("test1" & vbNewLine) + Set iDoc_.doc_ = doc + iDoc_.gid_ = 123 + + Call iDoc_.CreateTitleLink + Dim sAddr$: sAddr = "http://internet.garant.ru/document/redirect/123/0" + Call Dev_AssertEQ(1, doc.Hyperlinks.Count, "Hyperlink count") + Call Dev_ExpectEQ("test1", doc.Hyperlinks(1).Range.Text, "Hyperlink range") + Call Dev_ExpectEQ(sAddr, doc.Hyperlinks(1).Address, "Hyperlink address") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_AddHyperlink() + On Error GoTo PROPAGATE_ERROR + + Dim doc As Word.Document: Set doc = wordApp_.NewDocument + Call doc.Range.InsertAfter("test1 link test2" & vbNewLine) + Set iDoc_.doc_ = doc + iDoc_.linkSystem_ = PT_LOCAL + Call iDoc_.UpdateStyles(ThisDocument.FullName) + + Dim tRange As Word.Range: Set tRange = doc.Range(6, 10) + Dim iLink As New ItemLink: Call iLink.Init(123, "lnk_2", 1337, "sub_1", T_LINK_ASPECT) + + Call Dev_ExpectFalse(iDoc_.AddHyperlink(doc.Range(tRange.End, tRange.End), iLink, Style13), "Empty range") + Call Dev_ExpectTrue(iDoc_.AddHyperlink(tRange, iLink, Style13), "Valid add hyperlink") + Call Dev_ExpectEQ("link", tRange.Text, "Do not edit text") + Call Dev_AssertEQ(1, tRange.Hyperlinks.Count, "Hyperlinks count") + Call Dev_ExpectEQ("garantf1://1337.1/", tRange.Hyperlinks(1).Address, "Hyperlink address") + Call Dev_AssertEQ(1, tRange.Bookmarks.Count, "Bookmarks count") + Call Dev_ExpectEQ("lnk_2", tRange.Bookmarks(1).Name, "Bookmarks name") + tRange.Start = tRange.End - Len(tRange.Text) + Call Dev_ExpectEQ(Style13, tRange.Style, "Apply formatting Style") + + Call doc.Range.InsertAfter("test2" & vbNewLine) + Call Dev_ExpectFalse(iDoc_.AddHyperlink(doc.Paragraphs.Last.Range, iLink, Style13), "Bookmark taken") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_FormatLink() + On Error GoTo PROPAGATE_ERROR + + Dim doc As Word.Document: Set doc = wordApp_.NewDocument + Call doc.Range.InsertAfter("test1" & vbNewLine) + Set iDoc_.doc_ = doc + iDoc_.gid_ = 123 + Call iDoc_.UpdateStyles(ThisDocument.FullName) + Call iDoc_.CreateTitleLink + + Dim hLink As Word.Hyperlink: Set hLink = doc.Hyperlinks(1) + Call iDoc_.FormatLink(hLink, T_LINK_DEFINITION, T_LINKS_IGNORE, T_LAWS_FULL, T_LAWS_FULL) + Call Dev_ExpectEQ(Style13, hLink.Range.Style, "Change style") + Call Dev_ExpectTrue(hLink.Range.Font.StrikeThrough, "Change StrikeThrough") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ApplyLinkStatus() + On Error GoTo PROPAGATE_ERROR + + Dim doc As Word.Document: Set doc = wordApp_.NewDocument + Call doc.Range.InsertAfter("test1" & vbNewLine) + Call doc.Hyperlinks.Add(doc.Paragraphs.First.Range, "http://mobileonline.garant.ru/document/redirect/1337/0") + Call iDoc_.Init(doc) + + Call Dev_NewCase("Status Ignore") + Call iDoc_.ApplyLinkStatus(doc.Hyperlinks(1), T_LINKS_IGNORE) + Call Dev_ExpectTrue(doc.Hyperlinks(1).Range.Font.StrikeThrough) + + Call Dev_NewCase("Status Add") + Call iDoc_.ApplyLinkStatus(doc.Hyperlinks(1), T_LINKS_ADD) + Call Dev_ExpectFalse(doc.Hyperlinks(1).Range.Font.StrikeThrough) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CountLinksIn() + On Error GoTo PROPAGATE_ERROR + + Dim doc As Word.Document: Set doc = wordApp_.NewDocument + Set iDoc_.doc_ = doc + Call Dev_ExpectEQ(0, iDoc_.CountLinksIn(doc.Range), "Empty Document") + + Call Dev_SetupThreeLinks(iDoc_) + Dim testRange As Word.Range: Set testRange = doc.Range + Call Dev_ExpectEQ(3, iDoc_.CountLinksIn(testRange), "Full range") + + testRange.End = doc.Hyperlinks(3).Range.Start + Call Dev_ExpectEQ(2, iDoc_.CountLinksIn(testRange), "Ends on link") + + testRange.End = doc.Hyperlinks(3).Range.Start + 1 + Call Dev_ExpectEQ(3, iDoc_.CountLinksIn(testRange), "Partial intersection") + + doc.Hyperlinks(2).Address = "invalid" + Call Dev_ExpectEQ(2, iDoc_.CountLinksIn(testRange), "Do not count invalid link") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CountLinksBefore() + On Error GoTo PROPAGATE_ERROR + + Dim doc As Word.Document: Set doc = wordApp_.NewDocument + Set iDoc_.doc_ = doc + Call Dev_ExpectEQ(0, iDoc_.CountLinksBefore(1), "Empty Document") + + Call Dev_SetupThreeLinks(iDoc_) + + Call Dev_ExpectEQ(0, iDoc_.CountLinksBefore(0), "Start of the document") + Call Dev_ExpectEQ(0, iDoc_.CountLinksBefore(-1), "Negative start") + Call Dev_ExpectEQ(doc.Hyperlinks.Count, iDoc_.CountLinksBefore(doc.Range.End), "End of the document") + Call Dev_ExpectEQ(doc.Hyperlinks.Count, iDoc_.CountLinksBefore(doc.Range.End + 100), "Past end of the document") + + Call Dev_ExpectEQ(1, iDoc_.CountLinksBefore(doc.Hyperlinks(1).Range.End), "End of hlink 1") + Call Dev_ExpectEQ(2, iDoc_.CountLinksBefore(doc.Hyperlinks(2).Range.End), "End of hlink 2") + Call Dev_ExpectEQ(3, iDoc_.CountLinksBefore(doc.Hyperlinks(3).Range.End), "End of hlink 3") + + Call Dev_ExpectEQ(0, iDoc_.CountLinksBefore(doc.Hyperlinks(1).Range.Start), "Start of hlink 1") + Call Dev_ExpectEQ(1, iDoc_.CountLinksBefore(doc.Hyperlinks(2).Range.Start), "Start of hlink 2") + Call Dev_ExpectEQ(2, iDoc_.CountLinksBefore(doc.Hyperlinks(3).Range.Start), "Start of hlink 3") + + Call Dev_ExpectEQ(1, iDoc_.CountLinksBefore(doc.Hyperlinks(1).Range.Start + 2), "Mid of hlink 1") + Call Dev_ExpectEQ(2, iDoc_.CountLinksBefore(doc.Hyperlinks(2).Range.Start + 2), "Mid of hlink 2") + Call Dev_ExpectEQ(3, iDoc_.CountLinksBefore(doc.Hyperlinks(3).Range.Start + 2), "Mid of hlink 3") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_FindNextUnresolved() + On Error GoTo PROPAGATE_ERROR + + Dim doc As Word.Document: Set doc = wordApp_.NewDocument + Set iDoc_.doc_ = doc + Call Dev_ExpectNothing(iDoc_.FindNextUnresolved(0), "Empty Document") + + Call Dev_SetupThreeLinks(iDoc_) + + Dim sLink1$: sLink1 = doc.Hyperlinks(1).Address + Dim sLink2$: sLink2 = doc.Hyperlinks(2).Address + Dim sLink3$: sLink3 = doc.Hyperlinks(3).Address + + Call Dev_ExpectEQ(sLink1, iDoc_.FindNextUnresolved(0).Address, "Start of the document") + Call Dev_ExpectEQ(sLink1, iDoc_.FindNextUnresolved(-1).Address, "Negative start") + Call Dev_ExpectNothing(iDoc_.FindNextUnresolved(doc.Range.End), "End of the document") + Call Dev_ExpectNothing(iDoc_.FindNextUnresolved(doc.Range.End + 100), "Past end of the document") + + Call Dev_ExpectEQ(sLink2, iDoc_.FindNextUnresolved(doc.Hyperlinks(1).Range.End).Address, "End of hlink 1") + Call Dev_ExpectEQ(sLink3, iDoc_.FindNextUnresolved(doc.Hyperlinks(2).Range.End).Address, "End of hlink 2") + Call Dev_ExpectEQ(sLink1, iDoc_.FindNextUnresolved(doc.Hyperlinks(3).Range.End).Address, "End of hlink 3") + + Call Dev_ExpectEQ(sLink1, iDoc_.FindNextUnresolved(doc.Hyperlinks(1).Range.Start).Address, "Start of hlink 1") + Call Dev_ExpectEQ(sLink2, iDoc_.FindNextUnresolved(doc.Hyperlinks(2).Range.Start).Address, "Start of hlink 2") + Call Dev_ExpectEQ(sLink3, iDoc_.FindNextUnresolved(doc.Hyperlinks(3).Range.Start).Address, "Start of hlink 3") + + Call Dev_ExpectEQ(sLink1, iDoc_.FindNextUnresolved(doc.Hyperlinks(1).Range.Start + 2).Address, "Mid of hlink 1") + Call Dev_ExpectEQ(sLink2, iDoc_.FindNextUnresolved(doc.Hyperlinks(2).Range.Start + 2).Address, "Mid of hlink 2") + Call Dev_ExpectEQ(sLink3, iDoc_.FindNextUnresolved(doc.Hyperlinks(3).Range.Start + 2).Address, "Mid of hlink 3") + + Call Dev_NewCase("Skip ignored") + doc.Hyperlinks(2).Range.Style = Style4A + Call Dev_ExpectEQ(sLink3, iDoc_.FindNextUnresolved(doc.Hyperlinks(1).Range.End).Address) + Call Dev_ExpectEQ(sLink3, iDoc_.FindNextUnresolved(doc.Hyperlinks(2).Range.End).Address) + Call Dev_ExpectEQ(sLink1, iDoc_.FindNextUnresolved(doc.Hyperlinks(3).Range.End).Address) + + Call Dev_NewCase("Skip accepted") + doc.Hyperlinks(2).Range.Style = Style11 + Call Dev_ExpectEQ(sLink3, iDoc_.FindNextUnresolved(doc.Hyperlinks(1).Range.End).Address) + Call Dev_ExpectEQ(sLink3, iDoc_.FindNextUnresolved(doc.Hyperlinks(2).Range.End).Address) + Call Dev_ExpectEQ(sLink1, iDoc_.FindNextUnresolved(doc.Hyperlinks(3).Range.End).Address) + + Call Dev_NewCase("Skip declined") + doc.Hyperlinks(2).Range.Style = Style10 + doc.Hyperlinks(2).Range.Font.StrikeThrough = True + Call Dev_ExpectEQ(sLink3, iDoc_.FindNextUnresolved(doc.Hyperlinks(1).Range.End).Address) + Call Dev_ExpectEQ(sLink3, iDoc_.FindNextUnresolved(doc.Hyperlinks(2).Range.End).Address) + Call Dev_ExpectEQ(sLink1, iDoc_.FindNextUnresolved(doc.Hyperlinks(3).Range.End).Address) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_IgnoreLawLinks() + On Error GoTo PROPAGATE_ERROR + + Dim doc As Word.Document: Set doc = wordApp_.NewDocument + Set iDoc_.doc_ = doc + Dim docsToIgnore As New Scripting.Dictionary + + On Error Resume Next + Call iDoc_.IgnoreLawLinks(docsToIgnore) + Call Dev_ExpectNoError("Empty Document") + On Error GoTo PROPAGATE_ERROR + + Call Dev_SetupThreeLinks(iDoc_) + + On Error Resume Next + Call iDoc_.IgnoreLawLinks(docsToIgnore) + Call Dev_ExpectNoError("Empty ignorelist") + On Error GoTo PROPAGATE_ERROR + + Dim gid1&: gid1 = ParseHyperlink(doc.Hyperlinks(1)).DocumentID + Dim gid2&: gid2 = ParseHyperlink(doc.Hyperlinks(2)).DocumentID + Dim gid3&: gid3 = ParseHyperlink(doc.Hyperlinks(3)).DocumentID + Dim rng1 As Word.Range: Set rng1 = doc.Hyperlinks(1).Range.Words.Last + Dim rng2 As Word.Range: Set rng2 = doc.Hyperlinks(2).Range.Words.Last + Dim rng3 As Word.Range: Set rng3 = doc.Hyperlinks(3).Range.Words.Last + + Call Dev_NewCase("Valid ignore") + Call docsToIgnore.Add(gid2, "") + Call docsToIgnore.Add(gid3, "") + Call iDoc_.IgnoreLawLinks(docsToIgnore) + Call Dev_ExpectEQ(Style10, rng1.Style) + Call Dev_ExpectEQ(Style4A, rng2.Style) + Call Dev_ExpectEQ(Style4A, rng3.Style) + + Call Dev_NewCase("Keep declined status") + doc.Hyperlinks(2).Range.Style = Style10 + doc.Hyperlinks(2).Range.Font.StrikeThrough = True + doc.Hyperlinks(3).Range.Style = Style10 + Call iDoc_.IgnoreLawLinks(docsToIgnore) + Call Dev_ExpectEQ(Style10, rng1.Style) + Call Dev_ExpectTrue(rng2.Font.StrikeThrough) + Call Dev_ExpectEQ(Style4A, rng2.Style) + Call Dev_ExpectEQ(Style4A, rng3.Style) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_RemoveLinksFrom() + On Error GoTo PROPAGATE_ERROR + + Dim doc As Word.Document: Set doc = wordApp_.NewDocument + Set iDoc_.doc_ = doc + Dim docsToIgnore As New Scripting.Dictionary + + On Error Resume Next + Call iDoc_.RemoveLinksFrom(doc.Range) + Call Dev_ExpectNoError("Empty Document") + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Remove all links") + Call Dev_SetupThreeLinks(iDoc_) + Call iDoc_.RemoveLinksFrom(doc.Range) + Call Dev_ExpectEQ(0, doc.Hyperlinks.Count) + + Call Dev_NewCase("Remove link precise") + Call Dev_SetupThreeLinks(iDoc_) + Dim rLink As Word.Range: Set rLink = doc.Hyperlinks(2).Range + Call iDoc_.RemoveLinksFrom(rLink) + Call Dev_ExpectEQ(2, doc.Hyperlinks.Count) + Call Dev_ExpectEQ(0, rLink.Hyperlinks.Count) + Call Dev_ExpectNE(Style10, rLink.Style) + + Call Dev_NewCase("Remove partial hit") + Call Dev_SetupThreeLinks(iDoc_) + Set rLink = doc.Hyperlinks(2).Range + rLink.Start = rLink.Start - 5 + rLink.End = rLink.End + 5 + Call iDoc_.RemoveLinksFrom(rLink) + Call Dev_ExpectEQ(2, doc.Hyperlinks.Count) + Call Dev_ExpectEQ(0, rLink.Hyperlinks.Count) + Call Dev_ExpectNE(Style10, rLink.Style) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_UpdateLinkTip() + On Error GoTo PROPAGATE_ERROR + + Dim dbWrap As API_XLWrapper: Set dbWrap = Dev_GetDatabase + Dim oDatabase As New InfoDatabase: Call oDatabase.Init(dbWrap.Document) + + Dim iData As ItemLaw: Set iData = GetDummyData + Call oDatabase.SetItem(iData.Clone) + + Dim doc As Word.Document: Set doc = wordApp_.NewDocument + Set iDoc_.doc_ = doc + Call doc.Range.InsertAfter("test" & vbNewLine) + Dim hLink As Word.Hyperlink: Set hLink = doc.Hyperlinks.Add(doc.Paragraphs.First.Range, "garantf1://123.0/") + + Call Dev_NewCase("Empty title") + iData.title_ = vbNullString + Call oDatabase.SetItem(iData.Clone) + Call iDoc_.UpdateLinkTip(hLink, iData.gid_, oDatabase) + Call Dev_ExpectEQ(vbNullString, hLink.ScreenTip) + + Call Dev_NewCase("Real title") + iData.title_ = "Some title law" + Call oDatabase.SetItem(iData.Clone) + Call iDoc_.UpdateLinkTip(hLink, iData.gid_, oDatabase) + Call Dev_ExpectEQ(iData.title_, hLink.ScreenTip) + + Call dbWrap.ReleaseDocument + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_GetParagraphLink() + On Error GoTo PROPAGATE_ERROR + + Dim doc As Word.Document: Set doc = wordApp_.NewDocument + Set iDoc_.doc_ = doc + iDoc_.gid_ = 1337 + Call Dev_ExpectEQ(vbNullString, iDoc_.GetParagraphLink(doc.Range), "Empty document") + + Call doc.Range.InsertAfter("test1" & vbNewLine & "test2" & vbNewLine) + Call Dev_ExpectEQ(vbNullString, iDoc_.GetParagraphLink(doc.Range), "No bookmarks") + + Call Dev_NewCase("Valid bookmark link") + Dim bmRange As Word.Range: Set bmRange = doc.Paragraphs(1).Range + Call bmRange.Bookmarks.Add("sub_12") + Call Dev_ExpectEQ("1337#sub_12", iDoc_.GetParagraphLink(bmRange)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_GetLawDescription() + On Error GoTo PROPAGATE_ERROR + + Dim doc As Word.Document: Set doc = wordApp_.NewDocument + Set iDoc_.doc_ = doc + iDoc_.gid_ = 1337 + Dim iLaw As ItemLaw + + Call Dev_NewCase("Empty document") + Set iLaw = iDoc_.GetLawDescription + Call Dev_AssertNotNothing(iLaw) + Call Dev_ExpectEQ(iDoc_.gid_, iLaw.gid_, "law id") + Call Dev_ExpectEQ(doc.Name, iLaw.fileName_, "File name") + Call Dev_ExpectEQ(vbNullString, iLaw.title_, "default title") + Call Dev_ExpectFalse(iLaw.isDummy_, "Is Dummy") + + Call Dev_NewCase("Invalid title") + doc.Range.Text = " Invalid title " + Set iLaw = iDoc_.GetLawDescription + Call Dev_ExpectEQ(iDoc_.gid_, iLaw.gid_, "law id") + Call Dev_ExpectEQ(doc.Name, iLaw.fileName_, "File name") + Call Dev_ExpectEQ("Invalid title", iLaw.title_, "trimmed title") + Call Dev_ExpectFalse(iLaw.isDummy_, "Is Dummy") + + Call Dev_NewCase("Parsable title") + Dim sTitle$: sTitle = " 23 2012 . N 126 " & _ + """ ... """ + doc.Range.Text = sTitle + Set iLaw = iDoc_.GetLawDescription + Call Dev_ExpectEQ(iDoc_.gid_, iLaw.gid_, "law id") + Call Dev_ExpectEQ(doc.Name, iLaw.fileName_, "File name") + Call Dev_ExpectEQ(" ... ", iLaw.attach_, "parsed attach") + Call Dev_ExpectEQ(" ", iLaw.creator_, "parsed creator") + Call Dev_ExpectEQ("23.03.2012", iLaw.date_, "parsed date") + Call Dev_ExpectEQ(" ... ", iLaw.header_, "parsed header") + Call Dev_ExpectFalse(iLaw.isDummy_, "Is Dummy") + Call Dev_ExpectFalse(iLaw.isScoped_, "Is Scoped") + Call Dev_ExpectEQ("N 126", iLaw.number_, "parsed number") + Call Dev_ExpectEQ(T_LAW_11_MINISTRY, iLaw.type_, "parsed type") + Call Dev_ExpectEQ(sTitle, iLaw.title_, "parsed title") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_InfoWordDatabase.cls b/src/test/s_InfoWordDatabase.cls new file mode 100644 index 0000000..6339b1b --- /dev/null +++ b/src/test/s_InfoWordDatabase.cls @@ -0,0 +1,35 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_InfoWordDatabase" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +' TODO: +' Public Function GenerateFileName(theTitle$) As String +' Public Function SyncLink(hLink As Word.Hyperlink, iDoc As InfoDocument) As IteratorLinkLaw +' Public Function LoadLinksFrom(target As InfoDocument) +' Public Function ExpressLinks(target As InfoDocument) +' Public Function ExpressDocuments(theType As TLawType, target As Word.Range) As Scripting.Dictionary +' Public Function AddLinkAfter(iLink As ItemLink, nWhereIndex&) As Boolean +' Public Function OpenHyperlink(sAddress$) As Boolean + +Private db_ As InfoWordDatabase +Private dbApp_ As API_XLWrapper + +Public Function Setup() + ' Mandatory setup function + Set db_ = New InfoWordDatabase + Set dbApp_ = Dev_GetDatabase + Dim oDatabase As New InfoDatabase: Call oDatabase.Init(dbApp_.Document) + Call db_.Init(oDatabase) +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call dbApp_.ReleaseDocument(bSaveChanges:=False) +End Function diff --git a/src/test/s_ItemHyperlink.cls b/src/test/s_ItemHyperlink.cls new file mode 100644 index 0000000..605b750 --- /dev/null +++ b/src/test/s_ItemHyperlink.cls @@ -0,0 +1,120 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_ItemHyperlink" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +' TODO: +' Public Function ValidateSync(itLink As IteratorLinkCached) + +Private iLink_ As ItemHyperlink + +Public Function Setup() + ' Mandatory setup function + Set iLink_ = New ItemHyperlink +End Function + +Public Function Teardown() + ' Mandatory teardown function +End Function + +Public Function t_Init() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Init default sub") + Call iLink_.Init(PT_INTERNET, 123) + Call Dev_ExpectEQ(PT_INTERNET, iLink_.LinkSystem) + Call Dev_ExpectEQ(123, iLink_.DocumentID) + Call Dev_ExpectEQ("sub_0", iLink_.BookmarkName) + + Call Dev_NewCase("Init custom sub") + Dim iLink2 As New ItemHyperlink + Call iLink2.Init(PT_INTERNET, 123, "sub_123") + Call Dev_ExpectEQ(PT_INTERNET, iLink2.LinkSystem) + Call Dev_ExpectEQ(123, iLink2.DocumentID) + Call Dev_ExpectEQ("sub_123", iLink2.BookmarkName) + + Call Dev_NewCase("Reinit") + Call iLink2.Init(PT_MOBILE, 321, "sub_321") + Call Dev_ExpectEQ(PT_MOBILE, iLink2.LinkSystem) + Call Dev_ExpectEQ(321, iLink2.DocumentID) + Call Dev_ExpectEQ("sub_321", iLink2.BookmarkName) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ToAddress() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Mobile garant") + Call iLink_.Init(PT_MOBILE, 1337) + Call Dev_ExpectEQ("http://mobileonline.garant.ru/document/redirect/1337/0", iLink_.ToAddress) + + Call Dev_NewCase("Local garant") + Call iLink_.Init(PT_LOCAL, 1337) + Call Dev_ExpectEQ("garantf1://1337.0/", iLink_.ToAddress) + + Call Dev_NewCase("IVO garant") + Call iLink_.Init(PT_INTERNET, 1337) + Call Dev_ExpectEQ("http://internet.garant.ru/document/redirect/1337/0", iLink_.ToAddress) + + Call Dev_NewCase("Custom sub") + Call iLink_.Init(PT_LOCAL, 1337, "sub_123") + Call Dev_ExpectEQ("garantf1://1337.123/", iLink_.ToAddress) + + Call Dev_NewCase("Custom lnk") + Call iLink_.Init(PT_LOCAL, 1337, "lnk_123") + Call Dev_ExpectEQ("garantf1://1337.123/", iLink_.ToAddress) + + Call Dev_NewCase("Invalid sub") + Call iLink_.Init(PT_LOCAL, 1337, "sub") + Call Dev_ExpectEQ("garantf1://1337.0/", iLink_.ToAddress) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_FromString() + On Error GoTo PROPAGATE_ERROR + + Call iLink_.Init(PT_LOCAL, 123) + Call Dev_ExpectFalse(iLink_.FromAddress(""), "Empty input") + Call Dev_ExpectEQ(PT_LOCAL, iLink_.LinkSystem, "Do not reset on failed load") + + Call Dev_ExpectFalse(iLink_.FromAddress("invalid"), "Invalid input") + Call Dev_ExpectFalse(iLink_.FromAddress("http://internet.garant.ru/document/redirect/"), "Missing GID") + Call Dev_ExpectFalse(iLink_.FromAddress("http://internet.garant.ru/document/redirect/123/"), "Missing SUB") + Call Dev_ExpectFalse(iLink_.FromAddress("garantf1://1338.3"), "Missing slash") + Call Dev_ExpectFalse(iLink_.FromAddress("http://internet.garant.ru/document/redirect/abc/1"), "Invalid GID") + Call Dev_ExpectFalse(iLink_.FromAddress("http://internet.garant.ru/document/redirect/123/abc"), "Invalid SUB") + + Call Dev_NewCase("Mobile garant") + Call Dev_ExpectTrue(iLink_.FromAddress("http://mobileonline.garant.ru/document/redirect/1337/2")) + Call Dev_ExpectEQ(PT_MOBILE, iLink_.LinkSystem) + Call Dev_ExpectEQ(1337, iLink_.DocumentID) + Call Dev_ExpectEQ("sub_2", iLink_.BookmarkName) + + Call Dev_NewCase("Local garant") + Call Dev_ExpectTrue(iLink_.FromAddress("garantf1://1338.3/")) + Call Dev_ExpectEQ(PT_LOCAL, iLink_.LinkSystem) + Call Dev_ExpectEQ(1338, iLink_.DocumentID) + Call Dev_ExpectEQ("sub_3", iLink_.BookmarkName) + + Call Dev_NewCase("IVO garant") + Call Dev_ExpectTrue(iLink_.FromAddress("http://internet.garant.ru/document/redirect/1339/4")) + Call Dev_ExpectEQ(PT_INTERNET, iLink_.LinkSystem) + Call Dev_ExpectEQ(1339, iLink_.DocumentID) + Call Dev_ExpectEQ("sub_4", iLink_.BookmarkName) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_IteratorLaw.cls b/src/test/s_IteratorLaw.cls new file mode 100644 index 0000000..dab39d4 --- /dev/null +++ b/src/test/s_IteratorLaw.cls @@ -0,0 +1,281 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_IteratorLaw" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Test law iterator ====== +Option Explicit + +' TODO: +' RemoveRow +' Public Function CreateIndexItem() As ItemCachedLaw +' Public Function Links() As IteratorLinkLaw +' Public Function Find(target$, colN As LawStruct) As Boolean +' Public Function SetData(dataItem As ItemLaw, nLinkBase&) + +Private db_ As InfoDatabase +Private iterator_ As IteratorLaw + +Public Function Setup() + ' Mandatory setup function + Set db_ = New InfoDatabase + Set iterator_ = New IteratorLaw + Dim iPath As New API_Path: Call iPath.FromString(TEST_FOLDER).ToGlobal(ThisWorkbook.Path) + Call db_.Init(ThisWorkbook, iPath.Text) +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call ClearAll +End Function + +Public Function t_Init() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty DB") + Call iterator_.Init(db_, ThisWorkbook.Sheets(HT03_SHT_DOCS)) + Call Dev_ExpectEQ(HT03_DEFAULT_FIRST_LINE, iterator_.Row) + + Call Dev_NewCase("Non-empty row") + Dim newData As New ItemLaw: Set newData = GetDummyData + Call db_.SetItem(newData.Clone) + Call iterator_.Init(db_, ThisWorkbook.Sheets(HT03_SHT_DOCS)) + Call Dev_ExpectEQ(newData.gid_, iterator_.ID) + + Call Dev_NewCase("Custom empty row") + Call iterator_.Init(db_, ThisWorkbook.Sheets(HT03_SHT_DOCS), 10) + Call Dev_ExpectEQ(0, iterator_.ID) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_RandomAccess() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Acccess to existing data") + Dim newData As New ItemLaw: Set newData = GetDummyData + Call db_.SetItem(newData.Clone) + Set iterator_ = db_.Data(newData.gid_) + Call Dev_ExpectEQ(iterator_.ID, iterator_.GetVaueIn(S_CD_ID)) + Call iterator_.SetVaueIn(S_CD_ID, 1338) + Call Dev_ExpectEQ(1338, iterator_.GetVaueIn(S_CD_ID)) + + Call Dev_NewCase("Acccess outside boundaries") + Call iterator_.SetVaueIn(100, 1337) + Call Dev_ExpectEQ(1337, iterator_.GetVaueIn(100)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_NamedAccess() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Read acccess") + Dim newData As New ItemLaw: Set newData = GetDummyData + Call db_.SetItem(newData.Clone) + Set iterator_ = db_.Data(newData.gid_) + Call Dev_ExpectEQ(newData.gid_, iterator_.ID) + Call Dev_ExpectEQ(newData.status_, iterator_.Status) + Call Dev_ExpectEQ(newData.type_, iterator_.DType) + Call Dev_ExpectEQ(newData.fileName_, iterator_.FileName) + Call Dev_ExpectEQ(newData.title_, iterator_.Title) + Call Dev_ExpectEQ(newData.typeTxt_, iterator_.TypeText) + Call Dev_ExpectEQ(newData.creator_, iterator_.Creator) + Call Dev_ExpectEQ(newData.date_, iterator_.CreationDate) + Call Dev_ExpectEQ(newData.header_, iterator_.Header) + Call Dev_ExpectEQ(newData.attach_, iterator_.Attachment) + Call Dev_ExpectEQ(newData.isScoped_, iterator_.IsScoped) + Call Dev_ExpectEQ(newData.isDummy_, iterator_.IsDummy) + Call Dev_ExpectEQ(HT03_INVALID_ROW, iterator_.LinkBase) + + Call Dev_NewCase("Modify access") + iterator_.FileName = "newFile" + Call Dev_ExpectEQ("newFile", iterator_.FileName) + iterator_.Status = T_LAWS_NOTDEFINED + Call Dev_ExpectEQ(T_LAWS_NOTDEFINED, iterator_.Status) + Call Dev_ExpectNE(T_LAWS_NOTDEFINED, db_.Cache(newData.gid_).status_, "Do not update Cache") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_Iteration() + On Error GoTo PROPAGATE_ERROR + + Dim data1 As New ItemLaw: Set data1 = GetDummyData + Dim data2 As New ItemLaw: Set data2 = GetDummyData + data2.gid_ = data1.gid_ + 1 + Call db_.SetItem(data1.Clone) + Call db_.SetItem(data2.Clone) + + Call Dev_NewCase("Database begin") + Set iterator_ = db_.Laws + Dim nRow&: nRow = HT03_DEFAULT_FIRST_LINE + Call Dev_ExpectFalse(iterator_.IsDone, "Is not end") + Call Dev_ExpectEQ(nRow, iterator_.Row, "Increment row") + Call Dev_ExpectEQ(data1.gid_, iterator_.ID, "Validate data") + + Call Dev_NewCase("Simple increment") + Call iterator_.Increment + nRow = nRow + 1 + Call Dev_ExpectFalse(iterator_.IsDone, "Is not end") + Call Dev_ExpectEQ(nRow, iterator_.Row, "Increment row") + Call Dev_ExpectEQ(data2.gid_, iterator_.ID, "Validate data") + + Call Dev_NewCase("Increment past end") + Call iterator_.Increment + nRow = nRow + 1 + Call Dev_ExpectTrue(iterator_.IsDone, "Is end") + Call Dev_ExpectEQ(nRow, iterator_.Row, "Increment row") + + Call Dev_NewCase("Increment past end") + Call iterator_.Increment + nRow = nRow + 1 + Call Dev_ExpectTrue(iterator_.IsDone, "Is end") + Call Dev_ExpectEQ(nRow, iterator_.Row, "Increment row") + + Call iterator_.GoFirst + Call Dev_ExpectEQ(HT03_DEFAULT_FIRST_LINE, iterator_.Row, "Goto First") + + Call iterator_.GoLast + Call Dev_ExpectEQ(nRow - 2, iterator_.Row, "Goto Last") + + Call iterator_.GoFirst + Call iterator_.Increment(3) + Call Dev_ExpectEQ(HT03_DEFAULT_FIRST_LINE + 3, iterator_.Row, "Increment custom") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_IsActive() + On Error GoTo PROPAGATE_ERROR + + Set iterator_ = db_.Laws + Call Dev_ExpectFalse(iterator_.IsActive, "Empty DB") + + iterator_.ID = 1337 + + iterator_.Status = T_LAWS_NOTDEFINED + Call Dev_ExpectFalse(iterator_.IsActive, "Undefined") + + iterator_.Status = T_LAWS_IGNORE + Call Dev_ExpectFalse(iterator_.IsActive, "Ignored") + + iterator_.Status = T_LAWS_FULL + Call Dev_ExpectTrue(iterator_.IsActive, "Full") + + iterator_.Status = T_LAWS_FRINGE + Call Dev_ExpectTrue(iterator_.IsActive, "Fringe") + + iterator_.Status = T_LAWS_OUTER + Call Dev_ExpectTrue(iterator_.IsActive, "Outer") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_HasLinks() + On Error GoTo PROPAGATE_ERROR + + Set iterator_ = db_.Laws + Call Dev_ExpectFalse(iterator_.HasLinks, "Empty DB") + + iterator_.ID = 1337 + + iterator_.Status = T_LAWS_NOTDEFINED + Call Dev_ExpectFalse(iterator_.HasLinks, "Undefined") + + iterator_.Status = T_LAWS_IGNORE + Call Dev_ExpectFalse(iterator_.HasLinks, "Ignored") + + iterator_.Status = T_LAWS_FULL + Call Dev_ExpectTrue(iterator_.HasLinks, "Full") + + iterator_.Status = T_LAWS_FRINGE + Call Dev_ExpectTrue(iterator_.HasLinks, "Fringe") + + iterator_.Status = T_LAWS_OUTER + Call Dev_ExpectFalse(iterator_.HasLinks, "Outer") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_IsLoaded() + On Error GoTo PROPAGATE_ERROR + + Set iterator_ = db_.Laws + Call Dev_ExpectFalse(iterator_.IsLoaded, "Empty DB") + + iterator_.ID = 1337 + iterator_.Status = T_LAWS_IGNORE + iterator_.DType = T_LAW_01_UNKNOWN + iterator_.IsDummy = False + iterator_.Title = "test title" + Call Dev_ExpectTrue(iterator_.IsLoaded, "Valid loaded") + + iterator_.IsDummy = True + Call Dev_ExpectFalse(iterator_.IsLoaded, "Dummy") + iterator_.IsDummy = False + + iterator_.Title = vbNullString + Call Dev_ExpectFalse(iterator_.IsLoaded, "No title") + + iterator_.Title = HT03_TITLE_NOT_LOADED + Call Dev_ExpectFalse(iterator_.IsLoaded, "Not loaded") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_HasInfoBlanks() + On Error GoTo PROPAGATE_ERROR + + Set iterator_ = db_.Laws + Call Dev_ExpectTrue(iterator_.HasInfoBlanks, "Empty DB") + + Call db_.SetItem(GetDummyData) + Call Dev_ExpectFalse(iterator_.HasInfoBlanks, "Non-empty data") + + iterator_.TypeText = vbNullString + Call Dev_ExpectTrue(iterator_.HasInfoBlanks, "TypeText") + iterator_.TypeText = "non-empty" + + iterator_.Creator = vbNullString + Call Dev_ExpectTrue(iterator_.HasInfoBlanks, "Creator") + iterator_.Creator = "non-empty" + + iterator_.CreationDate = vbNullString + Call Dev_ExpectTrue(iterator_.HasInfoBlanks, "CreationDate") + iterator_.TypeText = "non-empty" + + iterator_.Number = vbNullString + Call Dev_ExpectTrue(iterator_.HasInfoBlanks, "Number") + iterator_.Number = "non-empty" + + iterator_.Attachment = vbNullString + Call Dev_ExpectTrue(iterator_.HasInfoBlanks, "Attachment") + iterator_.Attachment = "non-empty" + + Call iterator_.SetVaueIn(S_D_TIME_SCOPED, "") + Call Dev_ExpectTrue(iterator_.HasInfoBlanks, "Time-scoped") + iterator_.IsScoped = False + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_IteratorLinkAll.cls b/src/test/s_IteratorLinkAll.cls new file mode 100644 index 0000000..d9a834d --- /dev/null +++ b/src/test/s_IteratorLinkAll.cls @@ -0,0 +1,184 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_IteratorLinkAll" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Test link iterator for all links ====== +Option Explicit + +' TODO: +' Iteration +' Public Function RemoveRow() +' Public Function Find(target$, colN As LinkStruct) As Boolean +' Public Function ImportData(src As Object) + +Private db_ As InfoDatabase +Private iterator_ As IteratorLinkAll + +Public Function Setup() + ' Mandatory setup function + Set iterator_ = New IteratorLinkAll + Set db_ = New InfoDatabase + Dim iPath As New API_Path: Call iPath.FromString(TEST_FOLDER).ToGlobal(ThisWorkbook.Path) + Call db_.Init(ThisWorkbook, iPath.Text) +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call ClearAll +End Function + +Public Function t_Init() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty DB") + Call iterator_.Init(db_, ThisWorkbook.Sheets(HT03_SHT_LINKS)) + Call Dev_ExpectEQ(HT03_DEFAULT_FIRST_LINE, iterator_.Row) + + Call Dev_NewCase("Non-empty row") + Dim newData As New ItemLaw: Set newData = GetDummyData + Call db_.SetItem(newData.Clone) + Call db_.SetLinksFor(newData.gid_, GenerateLinks) + Call Dev_ExpectEQ(newData.gid_, iterator_.SourceID) + Call Dev_ExpectTrue(db_.SetLinksFor(newData.gid_, GenerateLinks)) + + Call Dev_NewCase("Custom empty row") + Call iterator_.Init(db_, ThisWorkbook.Sheets(HT03_SHT_LINKS), db_.CountLinks + 10) + Call Dev_ExpectEQ(0, iterator_.SourceID) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_IsProcessed() + On Error GoTo PROPAGATE_ERROR + + Set iterator_ = db_.Links + Call Dev_ExpectTrue(iterator_.IsProcessed, "Empty DB") + + Call db_.SetItem(GetDummyData) + Call db_.SetItem(GetDummyData) + Dim law1 As IteratorLaw: Set law1 = db_.Laws + Dim law2 As IteratorLaw: Set law2 = db_.Laws: Call law2.Increment + law1.Status = T_LAWS_FULL + law2.Status = T_LAWS_FULL + law2.ID = law1.ID + 1 + Call db_.Recreate + Dim nInvalid&: nInvalid = law1.ID + 2 + + Call Dev_NewCase("Out links") + iterator_.SourceID = law1.ID + iterator_.DestinationID = nInvalid + iterator_.LType = T_LINK_DEFAULT + iterator_.Status = T_LINKS_ADD + Call Dev_ExpectFalse(iterator_.IsProcessed, "Link not processed") + + iterator_.Status = T_LINKS_IGNORE + Call Dev_ExpectTrue(iterator_.IsProcessed, "Ignored link") + iterator_.Status = T_LINKS_ADD + + law1.Status = T_LAWS_OUTER + Call db_.Recreate + Call Dev_ExpectTrue(iterator_.IsProcessed, "Link from outer law") + + law1.Status = T_LAWS_FRINGE + Call db_.Recreate + Call Dev_ExpectTrue(iterator_.IsProcessed, "Link from fringe law to undefined law") + law1.Status = T_LAWS_FULL + Call db_.Recreate + + Call Dev_NewCase("Inside links") + iterator_.DestinationID = law2.ID + Call Dev_ExpectFalse(iterator_.IsProcessed, "Link not processed") + + law2.Status = T_LAWS_IGNORE + Call db_.Recreate + Call Dev_ExpectTrue(iterator_.IsProcessed, "Link to ignored") + + law1.Status = T_LAWS_FRINGE + law2.Status = T_LAWS_FRINGE + Call db_.Recreate + Call Dev_ExpectFalse(iterator_.IsProcessed, "Link between fringe laws") + + law1.Status = T_LAWS_FULL + law2.Status = T_LAWS_FULL + Call db_.Recreate + iterator_.LType = T_LINK_ASPECT + Call Dev_ExpectTrue(iterator_.IsProcessed, "Processed link: aspect") + iterator_.LType = T_LINK_DEFINITION + Call Dev_ExpectTrue(iterator_.IsProcessed, "Processed link: definition") + iterator_.LType = T_LINK_FOUNDATION + Call Dev_ExpectTrue(iterator_.IsProcessed, "Processed link: foundation") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_IsActive() + On Error GoTo PROPAGATE_ERROR + + Set iterator_ = db_.Links + Call Dev_ExpectFalse(iterator_.IsActive, "Empty DB") + + Call db_.SetItem(GetDummyData) + Call db_.SetItem(GetDummyData) + Dim law1 As IteratorLaw: Set law1 = db_.Laws + Dim law2 As IteratorLaw: Set law2 = db_.Laws: Call law2.Increment + law1.Status = T_LAWS_FULL + law2.Status = T_LAWS_FULL + law2.ID = law1.ID + 1 + Call db_.Recreate + Dim nInvalid&: nInvalid = law1.ID + 2 + + iterator_.SourceID = law1.ID + iterator_.DestinationID = nInvalid + iterator_.LType = T_LINK_ASPECT + iterator_.Status = T_LINKS_ADD + Call Dev_ExpectFalse(iterator_.IsActive, "Link to unknown law") + + iterator_.SourceID = nInvalid + iterator_.DestinationID = law2.ID + Call Dev_ExpectFalse(iterator_.IsActive, "Link from unknown law") + + iterator_.SourceID = law1.ID + iterator_.LType = T_LINK_ASPECT + Call Dev_ExpectTrue(iterator_.IsActive, "Valid link: aspect") + iterator_.LType = T_LINK_DEFAULT + Call Dev_ExpectFalse(iterator_.IsActive, "Valid link: default") + iterator_.LType = T_LINK_DEFINITION + Call Dev_ExpectTrue(iterator_.IsActive, "Valid link: definition") + iterator_.LType = T_LINK_FOUNDATION + Call Dev_ExpectTrue(iterator_.IsActive, "Valid link: foundation") + + iterator_.Status = T_LINKS_IGNORE + Call Dev_ExpectFalse(iterator_.IsActive, "Valid link: ignore link") + iterator_.Status = T_LINK_ASPECT + + law2.Status = T_LAWS_IGNORE + Call db_.Recreate + Call Dev_ExpectFalse(iterator_.IsActive, "Link to ignored law") + + law1.Status = T_LAWS_OUTER + law2.Status = T_LAWS_FULL + Call db_.Recreate + Call Dev_ExpectFalse(iterator_.IsActive, "Link from outer law") + + law1.Status = T_LAWS_IGNORE + Call db_.Recreate + Call Dev_ExpectFalse(iterator_.IsActive, "Link from ignored law") + + law1.Status = T_LAWS_FRINGE + law2.Status = T_LAWS_NOTDEFINED + Call db_.Recreate + Call Dev_ExpectFalse(iterator_.IsActive, "Link from fringe to undefined") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_LayoutManager.cls b/src/test/s_LayoutManager.cls new file mode 100644 index 0000000..f563649 --- /dev/null +++ b/src/test/s_LayoutManager.cls @@ -0,0 +1,34 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_LayoutManager" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Test Schema layout ====== +Option Explicit + +' TODO: +' Public Function Init(aPage As Visio.Page, params As ItemImportOptions) +' Public Function AddNewShape(aLevel&) As Visio.Shape +' Public Function MoveLastInLevel(tShape As Shape, aLevel&) + +Public Function Setup() + ' Mandatory setup function +End Function + +Public Function Teardown() + ' Mandatory teardown function +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_QueryMaster.cls b/src/test/s_QueryMaster.cls new file mode 100644 index 0000000..d452c23 --- /dev/null +++ b/src/test/s_QueryMaster.cls @@ -0,0 +1,34 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_QueryMaster" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Test data view ====== +Option Explicit + +' TODO: +' Public Function Init(db As InfoDatabase) +' Public Function QueryLaws(aFilter As Object) +' Public Function QueryLinks(aFilter As Object) + +Public Function Setup() + ' Mandatory setup function +End Function + +Public Function Teardown() + ' Mandatory teardown function +End Function + +Public Function t_SetDB() + On Error GoTo PROPAGATE_ERROR + + + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_WordDataAccess.cls b/src/test/s_WordDataAccess.cls new file mode 100644 index 0000000..8a3c8df --- /dev/null +++ b/src/test/s_WordDataAccess.cls @@ -0,0 +1,65 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_WordDataAccess" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +' TODO: +' AccessDatabase + ' Check documents folder +' WordDatabaseAccess + +Private fso_ As Scripting.FileSystemObject + +Public Function Setup() + ' Mandatory setup function + Set fso_ = New Scripting.FileSystemObject + On Error Resume Next + Call fso_.DeleteFolder(Dev_GetTestFolder) + On Error GoTo 0 + Call EnsureFolderExists(Dev_GetTestFolder & "\" & HT03_DEFAULT_WORKDIR) +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call fso_.DeleteFolder(Dev_GetTestFolder) +End Function + +Public Function t_GetDatabaseDocument() + On Error GoTo PROPAGATE_ERROR + + Dim sFile$: sFile = Dev_GetTestFolder & "\" & HT03_DEFAULT_WORKDIR & "\" & "reference.docx" + Dim wordApp As New API_WordWrapper: Call wordApp.SetApplication(ThisDocument.Application) + Dim doc As Word.Document: Set doc = wordApp.NewDocument() + Call wordApp.SaveAs(sFile) + + Call Dev_ExpectNothing(GetDatabaseDocument(doc), "DB missing") + + Dim dbWrap As API_XLWrapper: Set dbWrap = Dev_GetDatabase + Dim sFileDB$: sFileDB = dbWrap.Document.FullName + Call dbWrap.ReleaseDocument + + Call Dev_NewCase("Parent folder DB") + Dim dbWB As Excel.Workbook: Set dbWB = GetDatabaseDocument(doc) + Call Dev_ExpectEQ(sFileDB, GetDatabaseDocument(doc).FullName) + Call dbWB.Close(SaveChanges:=False) + + Call Dev_NewCase("Same folder DB") + Dim sNewFileDB$: sNewFileDB = doc.Path & "\" & HT03_DBNAME + Call fso_.MoveFile(sFileDB, sNewFileDB) + Set dbWB = GetDatabaseDocument(doc) + Call Dev_ExpectEQ(sNewFileDB, GetDatabaseDocument(doc).FullName) + Call dbWB.Close(SaveChanges:=False) + + Call wordApp.ReleaseDocument + + Exit Function +PROPAGATE_ERROR: + Call wordApp.ReleaseDocument + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/view/DataAccess.bas b/src/view/DataAccess.bas new file mode 100644 index 0000000..2923bc7 --- /dev/null +++ b/src/view/DataAccess.bas @@ -0,0 +1,111 @@ +Attribute VB_Name = "DataAccess" +' +Option Explicit + +Public Function GetDBPath() As String + GetDBPath = ThisWorkbook.Names(VIEW_CELL_DBPATH).RefersToRange.Text +End Function + +Public Function AccessDatabase() As API_XLWrapper + Dim inputPath$: inputPath = GetDBPath + + Dim result As New API_XLWrapper + Call result.SetApplication(ThisWorkbook.Application) + If result.OpenDocument(inputPath, bReadOnly:=True) Is Nothing Then + Call UserInteraction.ShowMessage(EM_DATABASE_NOT_FOUND) + Else + Set AccessDatabase = result + End If +End Function + +Public Function AccessLocal() As InfoDatabase + Set AccessLocal = New InfoDatabase + Call AccessLocal.Init(ThisWorkbook, ThisWorkbook.Names(VIEW_CELL_LAWS).RefersToRange) +End Function + +Public Function GetVisibleLaws() As Scripting.Dictionary + Set GetVisibleLaws = New Scripting.Dictionary + Dim docsSht As Excel.Worksheet: Set docsSht = GetActiveDocsSheet + Dim idsRange As Excel.Range: Set idsRange = docsSht.Range("A2:A" & docsSht.UsedRange.Rows.Count).SpecialCells(xlCellTypeVisible) + Dim theDB As InfoDatabase: Set theDB = AccessLocal + Dim aCell As Excel.Range + For Each aCell In idsRange + Dim gid&: gid = VBA.CLng(aCell.Text) + If theDB.Contains(gid) Then _ + Call GetVisibleLaws.Add(gid, 0) + Next aCell +End Function + +Public Function GetSelectedLaws() As Scripting.Dictionary + Dim sel As Excel.Range: Set sel = ThisWorkbook.Application.Selection + If sel.Parent.Parent.Name <> ThisWorkbook.Name Then + Call UserInteraction.ShowMessage(EM_INVALID_SELECTION) + Exit Function + End If + + Dim theDB As InfoDatabase: Set theDB = AccessLocal + Set GetSelectedLaws = New Scripting.Dictionary + Dim aCell As Excel.Range + For Each aCell In sel + Dim sText$: sText = aCell + If IsNumeric(sText) Then + Dim gid&: gid = CLng(sText) + If theDB.Contains(gid) Then _ + Call GetSelectedLaws.Add(gid, 0) + End If + Next aCell +End Function + +Public Function VisibleLinkRows() As Collection + Dim linksSht As Excel.Worksheet: Set linksSht = ThisWorkbook.Sheets(SHT_LINKS) + Dim lnksRange As Excel.Range: Set lnksRange = linksSht.Range("A2:A" & linksSht.UsedRange.Rows.Count).SpecialCells(xlCellTypeVisible) + + Set VisibleLinkRows = New Collection + Dim aCell As Excel.Range + For Each aCell In lnksRange + Call VisibleLinkRows.Add(CStr(aCell.Row), CStr(aCell.Row)) + Next aCell +End Function + +' template linkFilter +' !requires function CheckLink(IteratorLinkAll) -> Boolean +Public Function CreateGraph(Optional iFilter As Object = Nothing) As CDS_Graph + Set CreateGraph = New CDS_Graph + Dim Data As InfoDatabase: Set Data = AccessLocal + Dim docIter As IteratorLaw: Set docIter = Data.Laws + Do While Not docIter.IsDone + Call CreateGraph.AddNode(CStr(docIter.ID)) + Call docIter.Increment + Loop + + Dim iLink As IteratorLinkAll: Set iLink = Data.Links + Do While Not iLink.IsDone + If Not iFilter Is Nothing Then _ + If Not iFilter.CheckLink(iLink) Then _ + GoTo NEXT_LINK + + Call CreateGraph.AddEdge(iLink.SourceID, iLink.DestinationID) + +NEXT_LINK: + Call iLink.Increment + Loop +End Function + +Public Function DoIncludeTBALinks() As Boolean + DoIncludeTBALinks = ThisWorkbook.Names(PARAM_INCLUDE_TBA).RefersToRange = "" +End Function + +' ======= +Private Function GetActiveDocsSheet() As Excel.Worksheet + If Excel.Application.ActiveWorkbook.Name <> ThisWorkbook.Name Then + Set GetActiveDocsSheet = ThisWorkbook.Sheets(SHT_DOCS) + Exit Function + End If + + Dim activeName$: activeName = Application.ActiveSheet.Name + If activeName = SHT_DOCS Or activeName = SHT_IGNORE Or activeName = SHT_OUT_DOCS Then + Set GetActiveDocsSheet = Application.ActiveSheet + Else + Set GetActiveDocsSheet = ThisWorkbook.Sheets(SHT_DOCS) + End If +End Function diff --git a/src/view/DataImporter.cls b/src/view/DataImporter.cls new file mode 100644 index 0000000..267c0f1 --- /dev/null +++ b/src/view/DataImporter.cls @@ -0,0 +1,162 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "DataImporter" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private cLinkDoc_(TLinkType.[_First] To TLinkType.[_Last]) As Long +Private cLinkTotal_(TLinkType.[_First] To TLinkType.[_Last]) As Long +Private cDocType_(1 To TLawType.[_Last]) As Long + +Private addTBA_ As Boolean +Private dest_ As InfoDatabase + +Private outIgnore_ As Excel.Worksheet +Private ignoreCount_ As Long + +Private outLaws_ As Excel.Worksheet + +Public Function Init(dest As InfoDatabase, addTBA As Boolean) + Set dest_ = dest + Set outIgnore_ = ThisWorkbook.Sheets(SHT_IGNORE) + Set outLaws_ = ThisWorkbook.Sheets(SHT_DOCS) + addTBA_ = addTBA +End Function + +Public Function LoadDocs(ByRef iSource As IteratorLaw) + ignoreCount_ = 0 + Do While Not iSource.IsDone + If iSource.IsActive Then + Call dest_.SetItem(iSource.Data) + cDocType_(iSource.DType) = cDocType_(iSource.DType) + 1 + ElseIf iSource.Status = T_LAWS_IGNORE Then + Call AddIgnored(iSource) + End If + Call iSource.Increment + Call CSE_ProgressBar.IncrementA(DOCS_PROGRESS_FACTOR) + Call CSE_ProgressBar.IncrementB + Loop + Call UpdateDocCounts +End Function + +Public Function LoadLinks(ByRef iSource As IteratorLinkAll) + Dim iDestination As IteratorLinkAll: Set iDestination = dest_.Links + Call iDestination.GotoInsertion + + Dim docID&: docID = HT03_INVALID_GID + Do While Not iSource.IsDone + iSource.IsActive + If Not CheckLink(iSource) Then _ + GoTo NEXT_LINK + + If docID <> iSource.SourceID Then + If docID <> HT03_INVALID_GID Then + Call OuputDocStats(docID) + Call AggregateTotals + End If + docID = iSource.SourceID + dest_.Data(docID).LinkBase = iDestination.Row + End If + + Call iDestination.ImportData(iSource) + cLinkDoc_(iSource.LType) = cLinkDoc_(iSource.LType) + 1 + Call iDestination.Increment + +NEXT_LINK: + Call iSource.Increment + Call CSE_ProgressBar.IncrementA + Call CSE_ProgressBar.IncrementB + Loop + + If docID <> HT03_INVALID_GID Then + Call OuputDocStats(docID) + Call AggregateTotals + End If + + Call UpdateLinkCounts +End Function + +' ========== +Private Function CheckLink(iLink As IteratorLinkAll) As Boolean + CheckLink = False + + Dim srcID&: srcID = iLink.SourceID + Dim destID&: destID = iLink.DestinationID + If srcID = destID Then _ + Exit Function + If iLink.Status = T_LINKS_IGNORE Then _ + Exit Function + If Not addTBA_ Then _ + If iLink.LType = T_LINK_DEFAULT Then _ + Exit Function + + If Not dest_.Contains(srcID) Or Not dest_.Contains(destID) Then _ + Exit Function + + Dim sourceStatus As TLawStatus: sourceStatus = dest_.Cache(srcID).status_ + If sourceStatus = T_LAWS_OUTER Then _ + Exit Function + + If sourceStatus = T_LAWS_FRINGE Then _ + If dest_.Cache(destID).status_ = T_LAWS_NOTDEFINED Then _ + Exit Function + + CheckLink = True +End Function + +Private Function AddIgnored(source As IteratorLaw) + Dim outRow&: outRow = HT03_DEFAULT_FIRST_LINE + ignoreCount_ + outIgnore_.Cells(outRow, S_I_GARANT_ID) = source.ID + outIgnore_.Cells(outRow, S_I_TYPE) = source.DType + outIgnore_.Cells(outRow, S_I_FILENAME) = source.FileName + outIgnore_.Cells(outRow, S_I_TITLE) = source.Title + + ignoreCount_ = ignoreCount_ + 1 +End Function + +Private Function UpdateDocCounts() + ThisWorkbook.Names(STATS_DOCS_IGNORE).RefersToRange = ignoreCount_ + Dim totalCount& + Dim nType& + For nType = 1 To TLawType.[_Last] + ThisWorkbook.Names(STATS_DOCS_TOTAL).RefersToRange.Offset(nType - TLawType.[_Last] - 1) = cDocType_(nType) + totalCount = totalCount + cDocType_(nType) + Next nType + ThisWorkbook.Names(STATS_DOCS_TOTAL).RefersToRange = totalCount +End Function + +Private Function UpdateLinkCounts() + ThisWorkbook.Names(STATS_LNK_DEFAULT).RefersToRange = cLinkTotal_(T_LINK_DEFAULT) + ThisWorkbook.Names(STATS_LNK_ASPECT).RefersToRange = cLinkTotal_(T_LINK_ASPECT) + ThisWorkbook.Names(STATS_LNK_DEFINE).RefersToRange = cLinkTotal_(T_LINK_DEFINITION) + ThisWorkbook.Names(STATS_LNK_FOUND).RefersToRange = cLinkTotal_(T_LINK_FOUNDATION) + ThisWorkbook.Names(STATS_LNK_TOTAL).RefersToRange = cLinkTotal_(T_LINK_DEFAULT) _ + + cLinkTotal_(T_LINK_ASPECT) _ + + cLinkTotal_(T_LINK_DEFINITION) _ + + cLinkTotal_(T_LINK_FOUNDATION) +End Function + +Private Function OuputDocStats(target&) + Dim nRow&: nRow = dest_.Cache(target).row_ + outLaws_.Cells(nRow, SS_LINKS_DEFAULT) = cLinkDoc_(T_LINK_DEFAULT) + outLaws_.Cells(nRow, SS_LINKS_ASPECT) = cLinkDoc_(T_LINK_ASPECT) + outLaws_.Cells(nRow, SS_LINKS_DEFINE) = cLinkDoc_(T_LINK_DEFINITION) + outLaws_.Cells(nRow, SS_LINKS_FOUND) = cLinkDoc_(T_LINK_FOUNDATION) + outLaws_.Cells(nRow, SS_LINKS_TOTAL) = cLinkDoc_(T_LINK_DEFAULT) _ + + cLinkDoc_(T_LINK_FOUNDATION) _ + + cLinkDoc_(T_LINK_ASPECT) _ + + cLinkDoc_(T_LINK_DEFINITION) +End Function + +Private Function AggregateTotals() + Dim nType& + For nType = TLinkType.[_First] To TLinkType.[_Last] + cLinkTotal_(nType) = cLinkTotal_(nType) + cLinkDoc_(nType) + cLinkDoc_(nType) = 0 + Next nType +End Function diff --git a/src/view/Declarations.bas b/src/view/Declarations.bas new file mode 100644 index 0000000..2171ae5 --- /dev/null +++ b/src/view/Declarations.bas @@ -0,0 +1,105 @@ +Attribute VB_Name = "Declarations" +Option Private Module +Option Explicit + +Public Const HELP_BOOKMARK = "HT03_VIEW" +Public Const HELP_FILE_PATH = "\\fs1.concept.ru\Projects\10 \01 \-\! .docx" + +Public Const SHT_START = "Start" +Public Const SHT_DOCS = "" +Public Const SHT_IGNORE = "" +Public Const SHT_LINKS = "" +Public Const SHT_OUT_DOCS = "-" +Public Const SHT_OUT_LINKS = "-" + +Public Const VIEW_CELL_UPDATE = "c_UpdateDate" +Public Const VIEW_CELL_DBPATH = "c_DataPath" +Public Const VIEW_CELL_HASH = "c_Hash" +Public Const VIEW_CELL_LAWS = "c_LawLocation" +Public Const PARAM_INCLUDE_TBA = "c_IncludeTBA" + +Public Const STATS_LNK_DEFAULT = "sts_LnkTBA" +Public Const STATS_LNK_ASPECT = "sts_LnkAspect" +Public Const STATS_LNK_FOUND = "sts_LnkFoundation" +Public Const STATS_LNK_DEFINE = "sts_LnkDefine" +Public Const STATS_LNK_TOTAL = "sts_Links" +Public Const STATS_DOCS_TOTAL = "sts_Docs" +Public Const STATS_DOCS_IGNORE = "sts_Ignore" + +Public Const DOCS_PROGRESS_FACTOR = 10 + +' #NOTE: All UI enums should start with 0 because of ListIndex +' Type of documents source for Query +Public Enum TLawSource + T_LS_SELECTED = 0 + T_LS_VISIBLE = 1 + T_LS_FROM_ID = 2 +End Enum + +' Type of links for Query +Public Enum TQueryLink + T_QL_ALL = 0 + T_QL_FOUND = 1 + T_QL_DEFINITION = 2 + T_QL_ASPECT = 3 + T_QL_TBA = 4 +End Enum + +' Link follow direction +Public Enum TLinkDirection + T_LD_STRAIGHT = 0 + T_LD_REVERSE = 1 + T_LD_BOTH = 2 +End Enum + +' Document statistics columns +Public Enum StatsStruct + SS_LINKS_TOTAL = 15 ' + SS_LINKS_FOUND = 16 ' + SS_LINKS_DEFINE = 17 ' + SS_LINKS_ASPECT = 18 ' + SS_LINKS_DEFAULT = 19 ' +End Enum + +' _I_ Ignore document entry +Public Enum IgnoreStruct + [_First] = 1 + + S_I_GARANT_ID = 1 'ID + S_I_TYPE = 2 ' + S_I_FILENAME = 3 ' + S_I_TITLE = 4 ' + + [_Last] = 4 +End Enum + +' _QD_ Documents query response +Public Enum QueryLawsStruct + S_QD_ID = 1 + S_QD_TYPE = 2 + S_QD_TITLE = 3 + S_QD_TYPE_TXT = 4 + S_QD_CREATOR = 5 + S_QD_DATE = 6 + S_QD_NUMBER = 7 + S_QD_HEADER = 8 + S_QD_ATTACH = 9 + S_QD_TIME_SCOPED = 10 + S_QD_LNK_TOTAL = 11 + S_QD_LNK_FOUND = 12 + S_QD_LNK_DEFINE = 13 + S_QD_LNK_ASPECT = 14 +End Enum + +' _QL_ Links query response +Public Enum QueryLinksStruct + S_QL_SOURCE_ID = 1 + S_QL_SOURCE_SUB = 2 + S_QL_TARGET_ID = 3 + S_QL_TARGET_SUB = 4 + S_QL_TYPE = 5 + S_QL_SOURCE_TITLE = 6 + S_QL_SOURCE_TEXT = 7 + S_QL_TARGET_TITLE = 8 + S_QL_TARGET_TEXT = 9 +End Enum diff --git a/src/view/DevHelper.bas b/src/view/DevHelper.bas new file mode 100644 index 0000000..065d35e --- /dev/null +++ b/src/view/DevHelper.bas @@ -0,0 +1,25 @@ +Attribute VB_Name = "DevHelper" +Option Private Module +Option Explicit + +Public Const TEST_FOLDER = "testTemp" + +Public Function Dev_PrepareSkeleton() + ' Do nothing +End Function + +Public Function Dev_ManualRunTest() + Dim sSuite$: sSuite = "s_DatabaseView" + Dim sTest$: sTest = "t_SetDB" + 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_DatabaseView": Set Dev_GetTestSuite = New s_DatabaseView + Case "s_DataImporter": Set Dev_GetTestSuite = New s_DataImporter + Case "s_QueryMaster": Set Dev_GetTestSuite = New s_QueryMaster + End Select +End Function diff --git a/src/view/Main.bas b/src/view/Main.bas new file mode 100644 index 0000000..96328ae --- /dev/null +++ b/src/view/Main.bas @@ -0,0 +1,270 @@ +Attribute VB_Name = "Main" +Option Explicit + +Public Const PRODUCT_VERSION = "1.3.0" +Public Const PRODUCT_NAME = "Concept-NPA" + +Public g_VersionTimer As Long + +Public Sub Auto_Open() + Dim sCmd$: sCmd = OfficeCommandLine + If VBA.InStr(1, sCmd, "/automation", vbTextCompare) <> 0 Then _ + Exit Sub + + g_VersionTimer = SetTimer(0, 0, CP_VERSION_MSG_DELAY, AddressOf OnVersionCheck) +End Sub + +Public Function OnVersionCheck(ByVal nHwnd As Long, ByVal uMsg As Long, ByVal nEvent As Long, ByVal nTime As Long) + Call KillTimer(0, g_VersionTimer) + Call VersionValidate(PRODUCT_NAME, PRODUCT_VERSION) +End Function + +Public Function SetDB(sFile$) + ThisWorkbook.Names(VIEW_CELL_DBPATH).RefersToRange = sFile + Call RunUpdate +End Function + +Public Sub RunSetDB() + Dim sFileName$: sFileName = UserInteraction.PromptFileFilter(ThisWorkbook.Path, _ + sDescription:=" Excel", _ + sFilter:="*.xlsx;*.xls;*.xlsm") + If sFileName = vbNullString Then _ + Exit Sub + If sFileName = ThisWorkbook.Names(VIEW_CELL_DBPATH).RefersToRange Then _ + Exit Sub + + Call SetDB(sFileName) +End Sub + +Public Sub RunUpdate() + Dim dbInput As API_XLWrapper: Set dbInput = AccessDatabase() + If dbInput Is Nothing Then _ + Exit Sub + + Call ClearData + Dim iSource As New InfoDatabase: Call iSource.Init(dbInput.Document, GetDocumentsLocation(dbInput.Document)) + Call ImportData(iSource, AccessLocal) + Call dbInput.ReleaseDocument + + Call ThisWorkbook.Sheets(SHT_START).Activate + Call UserInteraction.ShowMessage(IM_IMPORT_SUCCESS) +End Sub + +Public Sub RunAddLaw() + Dim sFile$: sFile = UserInteraction.PromptFile(ThisWorkbook.Path) + If sFile = vbNullString Then _ + Exit Sub + + Dim wrapper As New API_WordWrapper + If wrapper.OpenDocument(sFile, bReadOnly:=True) Is Nothing Then _ + Exit Sub + + Dim bSuccess As Boolean: bSuccess = ProposeNewDocument(wrapper.Document, AccessLocal) + Call wrapper.ReleaseDocument + + If bSuccess Then _ + Call UserInteraction.ShowMessage(IM_NEW_DOC_SUCCESS) +End Sub + +Public Sub RunLoadLinkText() + If Not UserInteraction.AskQuestion(QM_LOAD_TEXTS) Then _ + Exit Sub + + Dim lnks As Excel.Worksheet: Set lnks = ThisWorkbook.Sheets(SHT_OUT_LINKS) + Dim localData As InfoDatabase: Set localData = AccessLocal + + Call CSE_ProgressBar.Init(" ", maxVal:=lnks.UsedRange.Rows.Count - HT03_DEFAULT_FIRST_LINE - 1, canInterrupt:=True) + Call CSE_ProgressBar.ShowModeless + Call localData.StartOptimization + + Call LoadTextsForLinks(localData, lnks) + + Call localData.EndOptimization + Call Unload(CSE_ProgressBar) + + Call UserInteraction.ShowMessage(IM_LOAD_TEXT_SUCCESS) +End Sub + +Public Sub RunUnstuck() + Dim uiWrap As New API_XLWrapper: Call uiWrap.SetDocument(ThisWorkbook) + Call uiWrap.ResumeUI + Call UserInteraction.ShowMessage(IM_UNSTUCK_SUCCESS) +End Sub + +Public Sub RunClearData() + If UserInteraction.AskQuestion(QM_CLEAR_IMPORTED_DATA) Then + Call ClearData + Call UserInteraction.ShowMessage(IM_CLEAR_SUCCESS) + End If +End Sub + +Public Sub RunClearAll() + If UserInteraction.AskQuestion(QM_CLEAR_DATA) Then + Call ClearData + Call ClearQueryLinks + Call ClearQueryDocs + End If +End Sub + +Public Sub RunExportData() +' Create Excel export for visualization and further processing + Dim xlApp As New API_XLWrapper + Call xlApp.SetApplication(ThisWorkbook.Parent) + 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 theDB As InfoDatabase: Set theDB = AccessLocal + Call CSE_ProgressBar.Init(" ", maxVal:=theDB.Count + theDB.CountLinks) + Call CSE_ProgressBar.InitSecondBar(maxVal:=theDB.Count) + CSE_ProgressBar.Description = " " + Call CSE_ProgressBar.ShowModeless + + Call xlApp.PauseUI + Call Output2Excel(outWB, theDB) + Call xlApp.ResumeUI + + Call Unload(CSE_ProgressBar) + + Call UserInteraction.ShowMessage(IM_EXPORT_SUCCESS) +End Sub + +Public Sub RunQueryLawsVisible() + Call ClearQueryDocs + + Dim theMaster As New QueryMaster: Call theMaster.Init(AccessLocal()) + Dim iFilter As New QFilterLaws: Call iFilter.Init(GetVisibleLaws()) + Call theMaster.QueryLaws(iFilter) + + Call ThisWorkbook.Sheets(SHT_OUT_DOCS).Activate +End Sub + +Public Sub RunQueryLawsOnce() + Dim iSelected As Scripting.Dictionary: Set iSelected = GetQueryDocsArgument(g_UIState.source_) + If iSelected Is Nothing Then _ + Exit Sub + + Call GraphExpandOnce(iSelected, g_UIState.linkType_, g_UIState.direction_) + + Call ClearQueryDocs + Dim theMaster As New QueryMaster: Call theMaster.Init(AccessLocal()) + Dim iFilter As New QFilterLaws: Call iFilter.Init(iSelected) + Call theMaster.QueryLaws(iFilter) + + Call ThisWorkbook.Sheets(SHT_OUT_DOCS).Activate +End Sub + +Public Sub RunQueryLawsFull() + Dim iSelected As Scripting.Dictionary: Set iSelected = GetQueryDocsArgument(g_UIState.source_) + If iSelected Is Nothing Then _ + Exit Sub + + Call GraphExpandFull(iSelected, g_UIState.linkType_, g_UIState.direction_) + + Call ClearQueryDocs + Dim theMaster As New QueryMaster: Call theMaster.Init(AccessLocal()) + Dim iFilter As New QFilterLaws: Call iFilter.Init(iSelected) + Call theMaster.QueryLaws(iFilter) + + Call ThisWorkbook.Sheets(SHT_OUT_DOCS).Activate +End Sub + +Public Sub RunLinksVisible() + Dim uiWrap As New API_XLWrapper: Call uiWrap.SetDocument(ThisWorkbook) + Call uiWrap.PauseUI + + Dim lnkRows As Collection: Set lnkRows = VisibleLinkRows() + Call ClearQueryLinks + + Dim theMaster As New QueryMaster: Call theMaster.Init(AccessLocal()) + Dim iFilter As New QFilterLinkRow: Call iFilter.Init(lnkRows) + Call theMaster.QueryLinks(iFilter) + + Call ThisWorkbook.Sheets(SHT_OUT_LINKS).Activate + + Call uiWrap.ResumeUI +End Sub + +Public Sub RunQueryLinksLaw() + Dim uiWrap As New API_XLWrapper: Call uiWrap.SetDocument(ThisWorkbook) + Call uiWrap.PauseUI + + Dim iSelected As Scripting.Dictionary: Set iSelected = GetQueryDocsArgument(g_UIState.source_) + If iSelected Is Nothing Then _ + Exit Sub + + Call ClearQueryLinks + + Dim theMaster As New QueryMaster: Call theMaster.Init(AccessLocal()) + Dim iFilter As New QFilterLinkComplex: Call iFilter.Init(iSelected, g_UIState.linkType_, g_UIState.direction_, onlyInternal:=False) + Call theMaster.QueryLinks(iFilter) + + Call ThisWorkbook.Sheets(SHT_OUT_LINKS).Activate + + Call uiWrap.ResumeUI +End Sub + +Public Sub RunQueryLinksInternal() + Dim uiWrap As New API_XLWrapper: Call uiWrap.SetDocument(ThisWorkbook) + Call uiWrap.PauseUI + + Dim iSelected As Scripting.Dictionary: Set iSelected = GetQueryDocsArgument(g_UIState.source_) + If iSelected Is Nothing Then _ + Exit Sub + + Call ClearQueryLinks + + Dim theMaster As New QueryMaster: Call theMaster.Init(AccessLocal()) + Dim iFilter As New QFilterLinkComplex: Call iFilter.Init(iSelected, g_UIState.linkType_, g_UIState.direction_, onlyInternal:=True) + Call theMaster.QueryLinks(iFilter) + + Call ThisWorkbook.Sheets(SHT_OUT_LINKS).Activate + + Call uiWrap.ResumeUI +End Sub + +Public Sub RunHelp() +' Open help file + Dim wordWrap As New API_WordWrapper + Dim helpDoc As Word.Document: Set helpDoc = wordWrap.OpenDocument(HELP_FILE_PATH, bReadOnly:=True) + If helpDoc Is Nothing Then _ + Exit Sub + With helpDoc + .Application.ActiveWindow.View.ReadingLayout = False + Call .ActiveWindow.ScrollIntoView(helpDoc.Bookmarks(HELP_BOOKMARK).Range) + Call .Application.Activate + End With +End Sub + +Public Sub RunOpenLawsLocation() + Dim oShell As New Shell32.Shell + Call oShell.Open(AccessLocal().docsLocation_) +End Sub + +Public Function GetDocumentLevel(rType As TLawType) As Long + GetDocumentLevel = DefaultLawLevelFor(rType) +End Function + +' ================= +Private Function GetQueryDocsArgument(nSourceType As TLawSource) As Scripting.Dictionary + Select Case nSourceType + Case T_LS_SELECTED: Set GetQueryDocsArgument = GetSelectedLaws + Case T_LS_VISIBLE: Set GetQueryDocsArgument = GetVisibleLaws + Case T_LS_FROM_ID + Dim sInput$: sInput = UserInteraction.PromptInput(" ID ") + If sInput = vbNullString Or Not IsNumeric(sInput) Then + Call UserInteraction.ShowMessage(EM_INVALID_QUERY_INPUT) + Exit Function + End If + Dim gid&: gid = CLng(sInput) + If Not AccessLocal.Contains(gid) Then + Call UserInteraction.ShowMessage(EM_ID_NOT_FOUND) + Exit Function + End If + Set GetQueryDocsArgument = New Scripting.Dictionary + Call GetQueryDocsArgument.Add(gid, 0) + End Select +End Function + diff --git a/src/view/MainImpl.bas b/src/view/MainImpl.bas new file mode 100644 index 0000000..66329d5 --- /dev/null +++ b/src/view/MainImpl.bas @@ -0,0 +1,205 @@ +Attribute VB_Name = "MainImpl" +Option Private Module +Option Explicit + +Public Function ClearData() + ThisWorkbook.Sheets(SHT_START).Range("I3:I16") = vbNullString + ThisWorkbook.Sheets(SHT_START).Range("L3:L8") = vbNullString + ThisWorkbook.Sheets(SHT_DOCS).UsedRange.Offset(1).ClearContents + ThisWorkbook.Sheets(SHT_IGNORE).UsedRange.Offset(1).ClearContents + ThisWorkbook.Sheets(SHT_LINKS).UsedRange.Offset(1).ClearContents + + ThisWorkbook.Names(VIEW_CELL_HASH).RefersToRange = "" + ThisWorkbook.Names(VIEW_CELL_UPDATE).RefersToRange = "" + ThisWorkbook.Names(VIEW_CELL_LAWS).RefersToRange = "" +End Function + +Public Function ClearQueryDocs() + ThisWorkbook.Sheets(SHT_OUT_DOCS).UsedRange.Offset(1).ClearContents +End Function + +Public Function ClearQueryLinks() + ThisWorkbook.Sheets(SHT_OUT_LINKS).UsedRange.Offset(1).ClearContents +End Function + +Public Function ImportData(iSource As InfoDatabase, iDestination As InfoDatabase) + Call iDestination.StartOptimization + + Dim importer As New DataImporter: Call importer.Init(iDestination, DoIncludeTBALinks) + + Call CSE_ProgressBar.Init(" ", maxVal:=DOCS_PROGRESS_FACTOR * iSource.Count + iSource.CountLinks) + Call CSE_ProgressBar.InitSecondBar(maxVal:=iSource.Count) + CSE_ProgressBar.Description = " " + Call CSE_ProgressBar.ShowModeless + + Call importer.LoadDocs(iSource.Laws) + + CSE_ProgressBar.Description = " " + Call CSE_ProgressBar.InitSecondBar(maxVal:=iSource.CountLinks) + + Call importer.LoadLinks(iSource.Links) + Unload CSE_ProgressBar + + ThisWorkbook.Names(VIEW_CELL_HASH).RefersToRange = iSource.Hash + ThisWorkbook.Names(VIEW_CELL_UPDATE).RefersToRange = Now() + ThisWorkbook.Names(VIEW_CELL_LAWS).RefersToRange = iSource.docsLocation_ + + Call iDestination.EndOptimization +End Function + +Public Function ProposeNewDocument(target As Word.Document, theDB As InfoDatabase) As Boolean + ProposeNewDocument = False + + If Not CheckProposedDocument(target, theDB) Then _ + Exit Function + + Dim sName$: sName = VBA.Left(target.Name, VBA.InStr(target.Name, ".")) & "docx" + Dim dbFolder$: dbFolder = theDB.docsLocation_ & "\\" + Dim fso As New Scripting.FileSystemObject + If fso.FileExists(dbFolder & sName) Then + Call UserInteraction.ShowMessage(EN_FILE_EXISTS) + Exit Function + End If + + If Not fso.FolderExists(dbFolder) Then _ + Call MkDir(dbFolder) + Call target.SaveAs(dbFolder & sName, FileFormat:=wdFormatDocumentDefault) + ProposeNewDocument = True +End Function + +Public Function Output2Excel(outWB As Excel.Workbook, theDB As InfoDatabase) + Dim exporter As New ActiveStateExporter: Call exporter.Init(outWB, theDB) + + Dim lawIDs As New Scripting.Dictionary + Set lawIDs = exporter.ExportLaws() + + Call CSE_ProgressBar.InitSecondBar(maxVal:=theDB.CountLinks) + CSE_ProgressBar.Description = " " + + Call exporter.ExportLinks(lawIDs) +End Function + +Public Function LoadTextsForLinks(iSource As InfoDatabase, iDestination As Excel.Worksheet) + Dim iLoaded As New Scripting.Dictionary + Dim nRow&: nRow = HT03_DEFAULT_FIRST_LINE + Do While iDestination.Cells(nRow, S_QL_SOURCE_ID) <> vbNullString + Dim iLaw As IteratorLaw: Set iLaw = iSource.Data(iDestination.Cells(nRow, S_QL_SOURCE_ID)) + If Not iLaw Is Nothing Then + iDestination.Cells(nRow, S_QL_SOURCE_TITLE) = iLaw.Title + If Not iLoaded.Exists(iLaw.ID) Then + Call iLoaded.Add(iLaw.ID, 0) + Call LoadLawLinks(iLaw, iSource, iDestination) + End If + End If + + Set iLaw = iSource.Data(iDestination.Cells(nRow, S_QL_TARGET_ID)) + If Not iLaw Is Nothing Then + iDestination.Cells(nRow, S_QL_TARGET_TITLE) = iLaw.Title + If Not iLoaded.Exists(iLaw.ID) Then + Call iLoaded.Add(iLaw.ID, 0) + Call LoadLawLinks(iLaw, iSource, iDestination) + End If + End If + + nRow = nRow + 1 + Call CSE_ProgressBar.IncrementA + + DoEvents + If CSE_ProgressBar.Interrupted Then _ + Exit Function + Loop +End Function + +Public Function GraphExpandOnce(ByRef target As Scripting.Dictionary, lnkType As TQueryLink, lnkDir As TLinkDirection) + Dim linkFilter As New QFilterLinkType: Call linkFilter.Init(g_UIState.linkType_) + Dim theGraph As CDS_Graph: Set theGraph = CreateGraph(linkFilter) + Select Case lnkDir + Case T_LD_STRAIGHT: Call theGraph.ExpandOutsOnce(target) + Case T_LD_REVERSE: Call theGraph.ExpandInsOnce(target) + Case T_LD_BOTH: Call theGraph.ExpandBiderctionalOnce(target) + End Select +End Function + +Public Function GraphExpandFull(ByRef target As Scripting.Dictionary, lnkType As TQueryLink, lnkDir As TLinkDirection) + Dim linkFilter As New QFilterLinkType: Call linkFilter.Init(g_UIState.linkType_) + Dim theGraph As CDS_Graph: Set theGraph = CreateGraph(linkFilter) + Select Case lnkDir + Case T_LD_STRAIGHT: Call theGraph.ExpandOutputs(target) + Case T_LD_REVERSE: Call theGraph.ExpandInputs(target) + Case T_LD_BOTH: Call theGraph.ExpandBiderctional(target) + End Select +End Function + +' =========== +Private Function CheckProposedDocument(target As Word.Document, localData As InfoDatabase) As Boolean + Dim iDoc As New InfoDocument + If Not iDoc.Init(target) Then + CheckProposedDocument = True + Exit Function + End If + + Dim docIter As ItemCachedLaw: Set docIter = localData.Cache(iDoc.gid_) + If Not docIter Is Nothing Then + If docIter.status_ = T_LAWS_OUTER Then + CheckProposedDocument = True + Exit Function + End If + End If + If Not localData.FindByFileName(target.Name) Is Nothing Then + Call UserInteraction.ShowMessage(EM_FILENAME_TAKEN) + CheckProposedDocument = False + Exit Function + End If + + If localData.Contains(iDoc.gid_) Then + If localData.Data(iDoc.gid_).FileName <> HT03_FILE_NOT_LOADED Then + Call UserInteraction.ShowMessage(EM_ID_TAKEN) + CheckProposedDocument = False + Exit Function + End If + End If + + CheckProposedDocument = True +End Function + +Private Function IsDefaultBookmark(sBookmark$) As Boolean + IsDefaultBookmark = sBookmark = vbNullString Or sBookmark = "sub_0" +End Function + +Private Function LoadLawLinks(iLaw As IteratorLaw, iSource As InfoDatabase, iDestination As Excel.Worksheet) + Dim wordApp As New API_WordWrapper + Call wordApp.CreateApplication(bIsVisible:=False) + + Dim sourceDoc As Word.Document: Set sourceDoc = wordApp.OpenDocument(iSource.DocumentsRelativePath & iLaw.FileName, bReadOnly:=True) + If sourceDoc Is Nothing Then + Call wordApp.ReleaseApplication + Exit Function + End If + + CSE_ProgressBar.DescriptionTB = wordApp.Document.Name + Dim gid&: gid = iLaw.ID + Dim nRow&: nRow = HT03_DEFAULT_FIRST_LINE + Do While iDestination.Cells(nRow, 1) <> vbNullString + If iDestination.Cells(nRow, S_QL_SOURCE_ID) = gid Then + Dim subSource$: subSource = iDestination.Cells(nRow, S_QL_SOURCE_SUB) + If IsDefaultBookmark(subSource) Or Not sourceDoc.Bookmarks.Exists(subSource) Then + iDestination.Cells(nRow, S_QL_SOURCE_TEXT) = iLaw.Title + Else + iDestination.Cells(nRow, S_QL_SOURCE_TEXT) = sourceDoc.Bookmarks(subSource).Range.Text + End If + End If + + If iDestination.Cells(nRow, S_QL_TARGET_ID) = gid Then + Dim subDest$: subDest = iDestination.Cells(nRow, S_QL_TARGET_SUB) + If IsDefaultBookmark(subDest) Or Not sourceDoc.Bookmarks.Exists(subDest) Then + iDestination.Cells(nRow, S_QL_TARGET_TEXT) = iLaw.Title + Else + iDestination.Cells(nRow, S_QL_TARGET_TEXT) = sourceDoc.Bookmarks(subDest).Range.Text + End If + End If + nRow = nRow + 1 + Loop + + Call wordApp.ReleaseDocument + Call wordApp.ReleaseApplication +End Function diff --git a/src/view/QFilterLaws.cls b/src/view/QFilterLaws.cls new file mode 100644 index 0000000..03d0b16 --- /dev/null +++ b/src/view/QFilterLaws.cls @@ -0,0 +1,21 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "QFilterLaws" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Dim iLaws_ As Scripting.Dictionary + +Public Function Init(iLaws As Scripting.Dictionary) + Set iLaws_ = iLaws +End Function + +Public Function CheckLaw(iLaw As IteratorLaw) As Boolean + CheckLaw = iLaws_.Exists(iLaw.ID) +End Function + diff --git a/src/view/QFilterLinkComplex.cls b/src/view/QFilterLinkComplex.cls new file mode 100644 index 0000000..f342985 --- /dev/null +++ b/src/view/QFilterLinkComplex.cls @@ -0,0 +1,52 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "QFilterLinkComplex" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private laws_ As Scripting.Dictionary +Private linkType_ As TQueryLink +Private linkDir_ As TLinkDirection +Private onlyInternal_ As Boolean + +Public Function Init(iLaws As Scripting.Dictionary, theType As TQueryLink, linkDir As TLinkDirection, onlyInternal As Boolean) + Set laws_ = iLaws + linkType_ = theType + linkDir_ = linkDir + onlyInternal_ = onlyInternal +End Function + +Public Function CheckLink(aLink As IteratorLinkAll) As Boolean + CheckLink = False + If Not CheckType(aLink.LType) Then _ + Exit Function + + Dim isSource As Boolean: isSource = laws_.Exists(aLink.SourceID) + Dim isDestination As Boolean: isDestination = laws_.Exists(aLink.DestinationID) + If onlyInternal_ Then _ + If Not isSource Or Not isDestination Then _ + Exit Function + + Select Case linkDir_ + Case T_LD_STRAIGHT: CheckLink = isSource + Case T_LD_REVERSE: CheckLink = isDestination + Case T_LD_BOTH: + CheckLink = isSource Or isDestination + End Select +End Function + +' ======= +Private Function CheckType(LType As TLinkType) As Boolean + Select Case linkType_ + Case T_QL_ALL: CheckType = True + Case T_QL_ASPECT: CheckType = LType = T_LINK_ASPECT + Case T_QL_DEFINITION: CheckType = LType = T_LINK_DEFINITION + Case T_QL_FOUND: CheckType = LType = T_LINK_FOUNDATION + End Select +End Function + diff --git a/src/view/QFilterLinkRow.cls b/src/view/QFilterLinkRow.cls new file mode 100644 index 0000000..a809fc0 --- /dev/null +++ b/src/view/QFilterLinkRow.cls @@ -0,0 +1,20 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "QFilterLinkRow" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Dim rows_ As Collection + +Public Function Init(aRows As Collection) + Set rows_ = aRows +End Function + +Public Function CheckLink(aLink As IteratorLinkAll) As Boolean + CheckLink = InCollection(CStr(aLink.Row), rows_) +End Function diff --git a/src/view/QFilterLinkType.cls b/src/view/QFilterLinkType.cls new file mode 100644 index 0000000..52a7b52 --- /dev/null +++ b/src/view/QFilterLinkType.cls @@ -0,0 +1,26 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "QFilterLinkType" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private linkType_ As TQueryLink + +Public Function Init(theType As TQueryLink) + linkType_ = theType +End Function + +Public Function CheckLink(aLink As IteratorLinkAll) As Boolean + Select Case linkType_ + Case T_QL_ALL: CheckLink = True + Case T_QL_ASPECT: CheckLink = aLink.LType = T_LINK_ASPECT + Case T_QL_DEFINITION: CheckLink = aLink.LType = T_LINK_DEFINITION + Case T_QL_FOUND: CheckLink = aLink.LType = T_LINK_FOUNDATION + Case T_QL_TBA: CheckLink = aLink.LType = T_LINK_DEFAULT + End Select +End Function diff --git a/src/view/QueryMaster.cls b/src/view/QueryMaster.cls new file mode 100644 index 0000000..3aeef7c --- /dev/null +++ b/src/view/QueryMaster.cls @@ -0,0 +1,76 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "QueryMaster" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' Class for query processing +Option Explicit + +Private database_ As InfoDatabase +Private outLinks_ As Excel.Worksheet +Private outLaws_ As Excel.Worksheet +Private nLaw_ As Long +Private nLink_ As Long + +Private Sub Class_Initialize() + Set outLinks_ = ThisWorkbook.Sheets(SHT_OUT_LINKS) + Set outLaws_ = ThisWorkbook.Sheets(SHT_OUT_DOCS) + nLink_ = WorksheetFunction.CountA(outLinks_.Columns(1)) + 1 + nLaw_ = WorksheetFunction.CountA(outLaws_.Columns(1)) + 1 +End Sub + +Public Function Init(db As InfoDatabase) + Set database_ = db +End Function + +' template aFilter +' !requires function CheckLaw(IteratorLaw) -> Boolean +Public Function QueryLaws(aFilter As Object) + Dim docIter As IteratorLaw: Set docIter = database_.Laws + Do While Not docIter.IsDone + If aFilter.CheckLaw(docIter) Then + Call OutputLaw(docIter) + End If + Call docIter.Increment + Loop +End Function + +' template aFilter +' !requires function CheckLink(IteratorLinkAll) -> Boolean +Public Function QueryLinks(aFilter As Object) + Dim lnkIter As IteratorLinkAll: Set lnkIter = database_.Links + Do While Not lnkIter.IsDone + If aFilter.CheckLink(lnkIter) Then + Call OutputLink(lnkIter) + End If + Call lnkIter.Increment + Loop +End Function + +' =============== +Private Function OutputLaw(target As IteratorLaw) + outLaws_.Cells(nLaw_, S_QD_ID) = target.ID + outLaws_.Cells(nLaw_, S_QD_TYPE) = target.DType + outLaws_.Cells(nLaw_, S_QD_TITLE) = target.Title + outLaws_.Cells(nLaw_, S_QD_TYPE_TXT) = target.TypeText + outLaws_.Cells(nLaw_, S_QD_CREATOR) = target.Creator + outLaws_.Cells(nLaw_, S_QD_DATE) = target.CreationDate + outLaws_.Cells(nLaw_, S_QD_NUMBER) = target.Number + outLaws_.Cells(nLaw_, S_QD_HEADER) = target.Header + outLaws_.Cells(nLaw_, S_QD_ATTACH) = target.Attachment + outLaws_.Cells(nLaw_, S_QD_TIME_SCOPED) = IIf(target.IsScoped, 1, 0) + nLaw_ = nLaw_ + 1 +End Function + +Private Function OutputLink(target As IteratorLinkAll) + outLinks_.Cells(nLink_, S_QL_SOURCE_ID) = target.SourceID + outLinks_.Cells(nLink_, S_QL_SOURCE_SUB) = target.SourceSub + outLinks_.Cells(nLink_, S_QL_TARGET_ID) = target.DestinationID + outLinks_.Cells(nLink_, S_QL_TARGET_SUB) = target.DestinationSub + outLinks_.Cells(nLink_, S_QL_TYPE) = target.LType + nLink_ = nLink_ + 1 +End Function diff --git a/src/view/UIState.cls b/src/view/UIState.cls new file mode 100644 index 0000000..d079945 --- /dev/null +++ b/src/view/UIState.cls @@ -0,0 +1,20 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "UIState" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public source_ As TLawSource +Public linkType_ As TQueryLink +Public direction_ As TLinkDirection + +Private Sub Class_Initialize() + source_ = T_LS_SELECTED + linkType_ = T_QL_ALL + direction_ = T_LD_STRAIGHT +End Sub diff --git a/src/view/z_UIMessages.bas b/src/view/z_UIMessages.bas new file mode 100644 index 0000000..a680ced --- /dev/null +++ b/src/view/z_UIMessages.bas @@ -0,0 +1,100 @@ +Attribute VB_Name = "z_UIMessages" +' Messaging module +Option Private Module +Option Explicit + +Public Enum MsgCode + EM_DATABASE_NOT_FOUND + EM_FILENAME_TAKEN + EM_ID_TAKEN + EN_FILE_EXISTS + EM_FAILED_OUTPUT_CREATION + EM_INVALID_SELECTION + EM_INVALID_QUERY_INPUT + EM_ID_NOT_FOUND + + IM_IMPORT_SUCCESS + IM_UNSTUCK_SUCCESS + IM_CLEAR_SUCCESS + IM_NEW_DOC_SUCCESS + IM_LOAD_TEXT_SUCCESS + IM_EXPORT_SUCCESS + IM_QUERY_SUCCESS + + QM_LOAD_TEXTS + QM_CLEAR_DATA + QM_CLEAR_IMPORTED_DATA +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_DATABASE_NOT_FOUND + Call MsgBox(" . ", vbExclamation) + Case EM_FILENAME_TAKEN + Call MsgBox(" ", vbExclamation) + Case EM_ID_TAKEN + Call MsgBox(" ", vbExclamation) + Case EN_FILE_EXISTS + Call MsgBox(" ", vbExclamation) + Case EM_FAILED_OUTPUT_CREATION + Call MsgBox(" ", vbExclamation) + Case EM_INVALID_SELECTION + Call MsgBox(" . , ", vbExclamation) + Case EM_INVALID_QUERY_INPUT + Call MsgBox(" ", vbExclamation) + Case EM_ID_NOT_FOUND + Call MsgBox(" ", vbExclamation) + + Case IM_IMPORT_SUCCESS + Call MsgBox(" ", vbInformation) + Case IM_UNSTUCK_SUCCESS + Call MsgBox(" ", vbInformation) + Case IM_CLEAR_SUCCESS + Call MsgBox(" ", vbInformation) + Case IM_NEW_DOC_SUCCESS + Call MsgBox(" ", vbInformation) + Case IM_LOAD_TEXT_SUCCESS + Call MsgBox(" ", vbInformation) + Case IM_EXPORT_SUCCESS + Call MsgBox(" ", vbInformation) + Case IM_QUERY_SUCCESS + Call MsgBox(" ", 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_LOAD_TEXTS + answer = MsgBox(" ? ", vbYesNo + vbQuestion) + Case QM_CLEAR_DATA + answer = MsgBox(" ?", vbYesNo + vbQuestion) + Case QM_CLEAR_IMPORTED_DATA + answer = MsgBox(" ?", vbYesNo + vbQuestion) + + Case Else + Call MsgBox("Invalid message code", vbCritical) + End Select + UIAskQuestion = answer = vbYes +End Function diff --git a/src/view/z_UIRibbon.bas b/src/view/z_UIRibbon.bas new file mode 100644 index 0000000..43a8ee4 --- /dev/null +++ b/src/view/z_UIRibbon.bas @@ -0,0 +1,50 @@ +Attribute VB_Name = "z_UIRibbon" +Option Explicit + +Global g_UIState As New UIState + +Sub HT03_ViewRibbon(control As IRibbonControl) + Select Case control.ID + Case "SetDatabase": Call RunSetDB + Case "Update": Call RunUpdate + Case "ExportData": Call RunExportData + Case "AddLaw": Call RunAddLaw + Case "OpenLawsLocation": Call RunOpenLawsLocation + + Case "QueryLawsVisible": Call RunQueryLawsVisible + Case "QueryLawsOnce": Call RunQueryLawsOnce + Case "QueryLawsFull": Call RunQueryLawsFull + Case "QueryLinksVisible": Call RunLinksVisible + Case "QueryLinksLaw": Call RunQueryLinksLaw + Case "QueryLinksInternal": Call RunQueryLinksInternal + + Case "LoadLinkText": Call RunLoadLinkText + + Case "Unstuck": Call RunUnstuck + Case "Help": Call RunHelp + End Select +End Sub + +Sub OnDefaultDocSource(control As IRibbonControl, ByRef val) + val = g_UIState.source_ +End Sub + +Sub OnDefaultLinkType(control As IRibbonControl, ByRef val) + val = g_UIState.linkType_ +End Sub + +Sub OnDefaultLinkDirection(control As IRibbonControl, ByRef val) + val = g_UIState.direction_ +End Sub + +Sub OnSourceChange(control As IRibbonControl, idLabel As String, nIndex As Variant) + g_UIState.source_ = nIndex +End Sub + +Sub OnLinkTypeChange(control As IRibbonControl, idLabel As String, nIndex As Variant) + g_UIState.linkType_ = nIndex +End Sub + +Sub OnLinkDirectionChange(control As IRibbonControl, idLabel As String, nIndex As Variant) + g_UIState.direction_ = nIndex +End Sub diff --git a/src/visual/Declarations.bas b/src/visual/Declarations.bas new file mode 100644 index 0000000..c0a7254 --- /dev/null +++ b/src/visual/Declarations.bas @@ -0,0 +1,71 @@ +Attribute VB_Name = "Declarations" +Option Private Module +Option Explicit + +Public Const HELP_WORD_BOOKMARK = "HT03_VISIO" +Public Const HELP_FILE_PATH = "\\fs1.concept.ru\Projects\10 \01 \-\! .docx" + +' Master shapes names +Public Const MASTER_DOCUMENT = "" +Public Const MASTER_CONNECTOR = "" + +' Custom cells names +Public Const CELLSU_LNKTYPE = "User.LinkType" +Public Const CELLSU_DOCLEVEL = "User.DocLevel" + +' Max length of doc title +Public Const MAX_TITLE_LEN = 130 + +Public Const PREFIX_HEAD = "H" + +' ======== LayoutManager constants ================ +Public Const VERTICAL_GAP = 10# ' mm +Public Const HORIZONTAL_GAP = 10# ' mm +Public Const SHAPE_HEIGHT = 25# ' mm +Public Const SHAPE_WIDTH = 80# ' mm + +Public Const MM_TO_INCH = 25.4 + +Public Const MAX_LEVEL = 9 + +'# Layout Type +Public Enum VsoLayoutType + [_First] = 1 + + VLT_VERTICAL = 1 + VLT_HORIZONTAL = 2 + + [_Last] = 3 +End Enum + +' ======== XL constants ================ +Public Const XL_FIRST_LINE = 2 + +Public Enum DocsStruct + DS_ID = 1 + DS_LEVEL = 2 + DS_TITLE = 3 + DS_TYPE = 4 + DS_GID = 5 +End Enum + +Public Enum LinksStruct + LS_SOURCE = 1 + LS_TARGET = 2 + LS_TYPE = 3 +End Enum + +Public Function DocLevelText(docLvl&) As String + Select Case docLvl + Case 1: DocLevelText = " " + Case 2: DocLevelText = " " + Case 3: DocLevelText = ", , " + Case 4: DocLevelText = ", , " + Case 5: DocLevelText = " " + Case 6: DocLevelText = " , " + Case 7: DocLevelText = " " + Case 8: DocLevelText = " 8" + Case 9: DocLevelText = " 9" + End Select +End Function + diff --git a/src/visual/DevHelper.bas b/src/visual/DevHelper.bas new file mode 100644 index 0000000..20f7c79 --- /dev/null +++ b/src/visual/DevHelper.bas @@ -0,0 +1,19 @@ +Attribute VB_Name = "DevHelper" +Option Private Module +Option Explicit + +Public Function Dev_PrepareSkeleton() + +End Function + +Public Function Dev_ManualRunTest() +' Dim sSuite$: sSuite = "s_ExCollection" +' Dim sTest$: sTest = "t_InCollection" +' Call MsgBox(Dev_RunTest(sSuite, sTest)) +End Function + +Public Function Dev_GetTestSuite(sName$) As Object + Select Case sName + Case "s_LayoutManager": Set Dev_GetTestSuite = New s_LayoutManager + End Select +End Function diff --git a/src/visual/ImportDataDlg.frm b/src/visual/ImportDataDlg.frm new file mode 100644 index 0000000..cbef26c --- /dev/null +++ b/src/visual/ImportDataDlg.frm @@ -0,0 +1,146 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} ImportDataDlg + Caption = " " + ClientHeight = 6810 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 5835 + OleObjectBlob = "ImportDataDlg.frx":0000 + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "ImportDataDlg" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +' ======= Dialog for creating new Schema ============= +Option Explicit + +Private isCancelled_ As Boolean +Private xlAppl_ As API_XLWrapper + +Private Sub UserForm_Initialize() + isCancelled_ = True +End Sub + +Public Function GetResult() As ItemImportOptions + Dim iOptions As New ItemImportOptions + + iOptions.layout_ = IIf(optV.Value, VLT_VERTICAL, VLT_HORIZONTAL) + iOptions.sFile_ = tbFileName.Text + iOptions.links_ = cbRemoveLinks.Value = False + + Dim nLvl& + For nLvl = 1 To MAX_LEVEL + Call iOptions.levels_.Add(GetLevelValue(nLvl)) + Next nLvl + + Set GetResult = iOptions +End Function + +Public Property Get Cancelled() As Boolean + Cancelled = isCancelled_ +End Property + +Public Function Init(xlAppl As API_XLWrapper) + Set xlAppl_ = xlAppl +End Function + +' ==================== +Private Sub btnInput_Click() + Dim sFileName$: sFileName = UserInteraction.PromptFileFilter( _ + sInitialPath:=Visio.ActiveDocument.Path, _ + sDescription:=" ", _ + sFilter:="*.xlsx;*.xls;*.xlsm", _ + sTitle:=" Excel", _ + bNewApplication:=True) + If sFileName = vbNullString Then _ + Exit Sub + Call xlAppl_.ReleaseDocument(bCloseApplication:=False) + If xlAppl_.OpenDocument(sFileName, bReadOnly:=True) Is Nothing Then _ + Exit Sub + + tbFileName.Text = sFileName + Call LoadCounts +End Sub + +Private Sub cmdCancel_Click() + isCancelled_ = True + Me.Hide +End Sub + +Private Sub cmdOk_Click() + If tbFileName.Text = vbNullString Then + Call MsgBox(" -!", vbExclamation) + Else + If xlAppl_.Document Is Nothing Then _ + Call xlAppl_.OpenDocument(tbFileName.Text, bReadOnly:=True) + isCancelled_ = False + Me.Hide + End If +End Sub + +Private Sub LevelTB1_Change() + Call UpdateSum +End Sub + +Private Sub LevelTB2_Change() + Call UpdateSum +End Sub + +Private Sub LevelTB3_Change() + Call UpdateSum +End Sub + +Private Sub LevelTB4_Change() + Call UpdateSum +End Sub + +Private Sub LevelTB5_Change() + Call UpdateSum +End Sub + +Private Sub LevelTB6_Change() + Call UpdateSum +End Sub + +Private Sub LevelTB7_Change() + Call UpdateSum +End Sub + +Private Sub LevelTB8_Change() + Call UpdateSum +End Sub + +Private Sub LevelTB9_Change() + Call UpdateSum +End Sub + +' ================= +Private Function UpdateSum() + Dim val&: val = 0 + Dim i& + For i = 1 To MAX_LEVEL + val = val + GetLevelValue(i) + Next i + SumTB.Value = val + TBWidth.Value = Round(630 / 22# * val, 0) +End Function + +Private Function GetLevelValue(nLvl&) As Long + Dim txt$: txt = Me.Controls("LevelTB" & nLvl).Value + If IsNumeric(txt) Then _ + GetLevelValue = CLng(txt) +End Function + +Private Function LoadCounts() + Dim dataSht As Excel.Worksheet: Set dataSht = xlAppl_.Document.Sheets(1) + Dim counters(1 To 9) As Long + Dim nSum&: nSum = 0 + Dim nCounter& + For nCounter = 1 To 9 Step 1 + Me.Controls("tbCount" & nCounter).Value = xlAppl_.Application.WorksheetFunction.CountIf(dataSht.Columns(2), nCounter) + nSum = nSum + Me.Controls("tbCount" & nCounter).Value + Next nCounter + tbCountSum.Value = nSum +End Function diff --git a/src/visual/ImportDataDlg.frx b/src/visual/ImportDataDlg.frx new file mode 100644 index 0000000..b3bca0c Binary files /dev/null and b/src/visual/ImportDataDlg.frx differ diff --git a/src/visual/ImportManager.cls b/src/visual/ImportManager.cls new file mode 100644 index 0000000..5c4fc15 --- /dev/null +++ b/src/visual/ImportManager.cls @@ -0,0 +1,98 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ImportManager" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private out_ As Visio.Page +Private inLaws_ As Excel.Worksheet +Private inLinks_ As Excel.Worksheet +Private params_ As ItemImportOptions +Private layout_ As LayoutManager + +Public nLaws_ As Long +Public nLinks_ As Long + +Public Function Init(iSource As Excel.Workbook, iDestination As Visio.Page, iUserInput As ItemImportOptions) + nLaws_ = 0 + nLinks_ = 0 + Set out_ = iDestination + Set inLaws_ = iSource.Sheets(1) + Set inLinks_ = iSource.Sheets(2) + Set params_ = iUserInput + + Set layout_ = New LayoutManager + Call layout_.Init(iDestination, iUserInput) +End Function + +Public Function GenerateSchema() As Boolean + Call CSE_ProgressBar.Init(" ", " ...", maxVal:=CDbl(inLaws_.UsedRange.Rows.Count)) + Call CSE_ProgressBar.ShowModeless + + nLaws_ = XLLoadDocuments() + + If params_.links_ Then + Call CSE_ProgressBar.Init(CSE_ProgressBar.Title, " ...", maxVal:=CDbl(inLinks_.UsedRange.Rows.Count)) + nLinks_ = XLLoadLinks() + End If + + Call Unload(CSE_ProgressBar) +End Function + +' ================= +Private Function XLLoadDocuments() As Long + Dim newShape As Visio.Shape + Dim nRow&: nRow = XL_FIRST_LINE + Do While inLaws_.Cells(nRow, DS_ID) <> vbNullString + Set newShape = layout_.AddNewShape(inLaws_.Cells(nRow, DS_LEVEL)) + With newShape + .Name = "N" & inLaws_.Cells(nRow, DS_ID) + .Text = TrimDocTitle(inLaws_.Cells(nRow, DS_TITLE)) + End With + + Call CSE_ProgressBar.IncrementA + nRow = nRow + 1 + Loop + XLLoadDocuments = nRow - XL_FIRST_LINE +End Function + +Private Function XLLoadLinks() As Long + Dim nRow&: nRow = XL_FIRST_LINE + Dim newShape As Visio.Shape + Do While inLinks_.Cells(nRow, LS_SOURCE) <> vbNullString + Dim sSource$: sSource = "N" & inLinks_.Cells(nRow, LS_SOURCE) + Dim sDest$: sDest = "N" & inLinks_.Cells(nRow, LS_TARGET) + + Dim iSource As Visio.Shape: Set iSource = out_.Shapes(sSource) + Dim iDestination As Visio.Shape: Set iDestination = out_.Shapes(sDest) + + Set newShape = out_.Drop(FindMaster(ThisDocument, MASTER_CONNECTOR), 0, 0) + With newShape + .CellsU(CELLSU_LNKTYPE) = inLinks_.Cells(nRow, LS_TYPE) + Call .CellsU("BeginX").GlueTo(iSource.CellsU("PinX")) + Call .CellsU("EndX").GlueTo(iDestination.CellsU("PinX")) + End With + + Call CSE_ProgressBar.IncrementA + nRow = nRow + 1 + Loop + XLLoadLinks = nRow - XL_FIRST_LINE +End Function + +Private Function TrimDocTitle(sTitle$) As String + Dim sTxt$: sTxt = sTitle + If VBA.Len(sTxt) >= MAX_TITLE_LEN Then + sTxt = VBA.Left(sTxt, MAX_TITLE_LEN) + sTxt = VBA.StrReverse(sTxt) + sTxt = VBA.Mid(sTxt, VBA.InStr(sTxt, " ") + 1) + sTxt = VBA.StrReverse(sTxt) & " ..." + End If + TrimDocTitle = sTxt +End Function + + diff --git a/src/visual/ItemImportOptions.cls b/src/visual/ItemImportOptions.cls new file mode 100644 index 0000000..538bf8a --- /dev/null +++ b/src/visual/ItemImportOptions.cls @@ -0,0 +1,19 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ItemImportOptions" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public links_ As Boolean +Public layout_ As VsoLayoutType +Public sFile_ As String +Public levels_ As Collection + +Private Sub Class_Initialize() + Set levels_ = New Collection +End Sub diff --git a/src/visual/LayoutManager.cls b/src/visual/LayoutManager.cls new file mode 100644 index 0000000..1a57a18 --- /dev/null +++ b/src/visual/LayoutManager.cls @@ -0,0 +1,93 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "LayoutManager" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ========== Shape positioning on creation ============= +Option Explicit + +Private page_ As Visio.Page +Private layout_ As VsoLayoutType + +Private width_ As Double +Private height_ As Double + +Private headers_(1 To MAX_LEVEL) As Visio.Shape +Private counters_(1 To MAX_LEVEL) As Long ' Counters for last element on level +Private levelX_(1 To MAX_LEVEL) As Double +Private levelY_(1 To MAX_LEVEL) As Double +Private levelWidth_(1 To MAX_LEVEL) As Integer + +Public Function Init(aPage As Visio.Page, params As ItemImportOptions) + Set page_ = aPage + layout_ = params.layout_ + Dim nLvl& + For nLvl = 1 To MAX_LEVEL + levelWidth_(nLvl) = params.levels_(nLvl) + Next nLvl + + Call CreateHeaders + width_ = headers_(1).CellsU("Width") + height_ = headers_(1).CellsU("Height") +End Function + +Public Function AddNewShape(aLevel&) As Visio.Shape +' Creating new shape for level and moving it last in level + Dim result As Visio.Shape: Set result = page_.Drop(FindMaster(ThisDocument, MASTER_DOCUMENT), 0, 0) + result.CellsU(CELLSU_DOCLEVEL) = CStr(aLevel) + Call MoveLastInLevel(result, aLevel) + Set AddNewShape = result +End Function + +Public Function MoveLastInLevel(tShape As Shape, aLevel&) + Dim itemRow%: itemRow = counters_(aLevel) Mod levelWidth_(aLevel) + Dim itemColumn%: itemColumn = counters_(aLevel) \ levelWidth_(aLevel) + Dim pinx As Double, piny As Double + Select Case layout_ + Case VLT_HORIZONTAL: + pinx = levelX_(aLevel) + (1 + itemColumn) * (width_ + HORIZONTAL_GAP / MM_TO_INCH) + piny = levelY_(aLevel) - itemRow * (height_ + VERTICAL_GAP / MM_TO_INCH) + Case VLT_VERTICAL: + pinx = levelX_(aLevel) + itemRow * (width_ + HORIZONTAL_GAP / MM_TO_INCH) + piny = levelY_(aLevel) - (1 + itemColumn) * (height_ + VERTICAL_GAP / MM_TO_INCH) + End Select + + Call tShape.SetCenter(pinx, piny) + counters_(aLevel) = counters_(aLevel) + 1 +End Function + +'========= +Private Function CreateHeaders() +' Creating head shapes to position + Dim pinx As Double: pinx = 0 + Dim piny As Double: piny = 0 + Dim nLvl& + Dim headerShape As Visio.Shape + For nLvl = 1 To MAX_LEVEL + If levelWidth_(nLvl) <= 0 Then _ + GoTo NEXT_LVL + Set headerShape = page_.Drop(FindMaster(ThisDocument, MASTER_DOCUMENT), 0, 0) + Set headers_(nLvl) = headerShape + With headerShape + .CellsU(CELLSU_DOCLEVEL) = CStr(nLvl) + .Text = DocLevelText(nLvl) + .Name = PREFIX_HEAD & CStr(nLvl) + + Call .SetCenter(pinx, piny) + levelX_(nLvl) = pinx + levelY_(nLvl) = piny + + Select Case layout_ + Case VLT_VERTICAL: + pinx = pinx + levelWidth_(nLvl) * (.Cells("Width") + HORIZONTAL_GAP / MM_TO_INCH) + Case VLT_HORIZONTAL: + piny = piny - levelWidth_(nLvl) * (.Cells("Height") + VERTICAL_GAP / MM_TO_INCH) + End Select + End With +NEXT_LVL: + Next nLvl +End Function diff --git a/src/visual/Main.bas b/src/visual/Main.bas new file mode 100644 index 0000000..435ab9b --- /dev/null +++ b/src/visual/Main.bas @@ -0,0 +1,113 @@ +Attribute VB_Name = "Main" +Option Explicit + +Public Const PRODUCT_VERSION = "1.3.0" +Public Const PRODUCT_NAME = "Concept-NPA" + +Public g_VersionTimer As Long + +Public Sub StartVersionCheck() + g_VersionTimer = SetTimer(0, 0, CP_VERSION_MSG_DELAY, AddressOf OnVersionCheck) +End Sub + +Public Function OnVersionCheck(ByVal nHwnd As Long, ByVal uMsg As Long, ByVal nEvent As Long, ByVal nTime As Long) + Call KillTimer(0, g_VersionTimer) + Call VersionValidate(PRODUCT_NAME, PRODUCT_VERSION) +End Function + +Public Sub RunClearSchema() + If Not UserInteraction.AskQuestion(QM_CLEAR_ALL) Then _ + Exit Sub + + Call GlobalUndo.BeginScope(" ") + Call VsoClearPage(ThisDocument.Application.ActivePage) + Call GlobalUndo.EndScope + + Call VsoShowWholePage(ThisDocument.Application.ActivePage) +End Sub + +Public Sub RunCreateSchema() + Dim mainPage As Visio.Page: Set mainPage = ThisDocument.Application.ActivePage + If mainPage.Shapes.Count <> 0 Then _ + If Not UserInteraction.AskQuestion(QM_CLEAR_ALL) Then _ + Exit Sub + + Dim xlAppl As New API_XLWrapper + Call xlAppl.CreateApplication(bIsVisible:=False) + + Dim iUserInput As ItemImportOptions: Set iUserInput = PromptImportOptions(xlAppl) + If iUserInput Is Nothing Then _ + GoTo SAFE_EXIT + + Dim vsoUI As New API_VsoWrapper: Call vsoUI.SetDocument(ThisDocument) + Call vsoUI.PauseUI + Call GlobalUndo.BeginScope(" Excel") + + Call VsoClearPage(mainPage) + Dim importer As New ImportManager: Call importer.Init(xlAppl.Document, mainPage, iUserInput) + Call importer.GenerateSchema + + Call GlobalUndo.EndScope + Call vsoUI.ResumeUI + DoEvents + + Call mainPage.ResizeToFitContents + Call VsoShowWholePage(mainPage) + + Call UserInteraction.ShowMessage(IM_CREATION_COMPLETE, importer.nLaws_, importer.nLinks_) + +SAFE_EXIT: + Call xlAppl.ReleaseDocument + Call xlAppl.ReleaseApplication +End Sub + +Public Sub RunHelp() + Dim wordWrap As New API_WordWrapper + Dim helpDoc As Word.Document: Set helpDoc = wordWrap.OpenDocument(HELP_FILE_PATH, bReadOnly:=True) + If helpDoc Is Nothing Then _ + Exit Sub + + With helpDoc + .Application.ActiveWindow.View.ReadingLayout = False + Call .ActiveWindow.ScrollIntoView(helpDoc.Bookmarks(HELP_WORD_BOOKMARK).Range) + Call .Application.Activate + End With +End Sub + +Public Sub RunMoveDown() + Dim sel As Visio.Selection: Set sel = ThisDocument.Application.ActiveWindow.Selection + If sel.Count <> 0 Then + Call sel.Move(0#, -(SHAPE_HEIGHT + VERTICAL_GAP), visMillimeters) + End If +End Sub + +Public Sub RunMoveUp() + Dim sel As Visio.Selection: Set sel = ThisDocument.Application.ActiveWindow.Selection + If sel.Count <> 0 Then + Call sel.Move(0#, SHAPE_HEIGHT + VERTICAL_GAP, visMillimeters) + End If +End Sub + +Public Sub RunGotoLinkBegin() +Attribute RunGotoLinkBegin.VB_ProcData.VB_Invoke_Func = "Q" + Call CC_GotoLinkBegin +End Sub + +Public Sub RunGotoLinkEnd() +Attribute RunGotoLinkEnd.VB_ProcData.VB_Invoke_Func = "E" + Call CC_GotoLinkEnd +End Sub + +Public Sub RunMoveLeft() + Dim sel As Visio.Selection: Set sel = ThisDocument.Application.ActiveWindow.Selection + If sel.Count <> 0 Then + Call sel.Move(-(SHAPE_WIDTH + HORIZONTAL_GAP), 0#, visMillimeters) + End If +End Sub + +Public Sub RunMoveRight() + Dim sel As Visio.Selection: Set sel = ThisDocument.Application.ActiveWindow.Selection + If sel.Count <> 0 Then + Call sel.Move(SHAPE_WIDTH + HORIZONTAL_GAP, 0#, visMillimeters) + End If +End Sub diff --git a/src/visual/MainImpl.bas b/src/visual/MainImpl.bas new file mode 100644 index 0000000..3d5374a --- /dev/null +++ b/src/visual/MainImpl.bas @@ -0,0 +1,10 @@ +Attribute VB_Name = "MainImpl" +Option Private Module +Option Explicit + +Public Function PromptImportOptions(xlWrapper As API_XLWrapper) As ItemImportOptions + Call ImportDataDlg.Init(xlWrapper) + Call ImportDataDlg.Show + If Not ImportDataDlg.Cancelled Then _ + Set PromptImportOptions = ImportDataDlg.GetResult +End Function diff --git a/src/visual/ThisDocument.cls b/src/visual/ThisDocument.cls new file mode 100644 index 0000000..8d5a8b6 --- /dev/null +++ b/src/visual/ThisDocument.cls @@ -0,0 +1,22 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ThisDocument" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + +Private Sub Document_DocumentOpened(ByVal iDoc As IVDocument) + If iDoc.ID <> ThisDocument.ID Then _ + Exit Sub + + Dim sCmd$: sCmd = OfficeCommandLine + If VBA.InStr(1, sCmd, "/automation", vbTextCompare) <> 0 Then _ + Exit Sub + + Call StartVersionCheck +End Sub + diff --git a/src/visual/z_UIMessages.bas b/src/visual/z_UIMessages.bas new file mode 100644 index 0000000..6924d3b --- /dev/null +++ b/src/visual/z_UIMessages.bas @@ -0,0 +1,58 @@ +Attribute VB_Name = "z_UIMessages" +' Messaging module +Option Private Module +Option Explicit + +Public Enum MsgCode + MSG_OK = 0 + + ' EM_INVALID_SELECTION + + IM_CREATION_COMPLETE + + QM_CLEAR_ALL +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_INVALID_SELECTION +' Call MsgBox("Invalid selection, please select single data item", vbExclamation) + + Case IM_CREATION_COMPLETE + Call MsgBox(Fmt(" " & vbNewLine & _ + ": {1}" & vbNewLine & _ + ": {2}", unwrapped), 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_ALL + answer = MsgBox(" ?", vbYesNo + vbQuestion) + + Case Else + Call MsgBox("Invalid message code", vbCritical) + End Select + UIAskQuestion = answer = vbYes +End Function diff --git a/src/visual/z_UIRibbon.bas b/src/visual/z_UIRibbon.bas new file mode 100644 index 0000000..f1fc355 --- /dev/null +++ b/src/visual/z_UIRibbon.bas @@ -0,0 +1,17 @@ +Attribute VB_Name = "z_UIRibbon" +Option Explicit + +Public Sub OnAction(iControl As IRibbonControl) + Select Case iControl.ID + Case "CreateSchema": Call RunCreateSchema + Case "MoveUp": Call RunMoveUp + Case "MoveDown": Call RunMoveDown + Case "MoveLeft": Call RunMoveLeft + Case "MoveRight": Call RunMoveRight + Case "ClearSchema": Call RunClearSchema + + Case "Help": Call RunHelp + + Case Else: Call CC_DispatchCommand(iControl.ID) + End Select +End Sub diff --git a/test/001.docx b/test/001.docx new file mode 100644 index 0000000..93d788e Binary files /dev/null and b/test/001.docx differ diff --git a/test/002.docx b/test/002.docx new file mode 100644 index 0000000..a0f1ce5 Binary files /dev/null and b/test/002.docx differ diff --git a/test/MinimalDoc.docx b/test/MinimalDoc.docx new file mode 100644 index 0000000..32f90cd Binary files /dev/null and b/test/MinimalDoc.docx differ diff --git a/ui/addin/.rels b/ui/addin/.rels new file mode 100644 index 0000000..2b00f63 --- /dev/null +++ b/ui/addin/.rels @@ -0,0 +1,2 @@ + + \ No newline at end of file diff --git a/ui/addin/customUI.xml b/ui/addin/customUI.xml new file mode 100644 index 0000000..1dd7bea --- /dev/null +++ b/ui/addin/customUI.xml @@ -0,0 +1,108 @@ + + + + + + +