commit 2bd3bb3f127578826a14ab38c45befeb127f6494 Author: IRBorisov <8611739+IRBorisov@users.noreply.github.com> Date: Fri Jun 7 20:09:31 2024 +0300 Initial commit diff --git a/VBAMake.txt b/VBAMake.txt new file mode 100644 index 0000000..77ec724 --- /dev/null +++ b/VBAMake.txt @@ -0,0 +1,42 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact_home, source_home + +id = Concept-Mining +name = Концепт-Майнинг +description = Модуль извлечения (парсинга) данных из текстов +artifact_home = Концепт-Майнинг +source_home = Concept-Mining +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 +copy distr\models\ActionVerbs.txt -> models\ActionVerbs.txt + +build script\addinManifest.txt +build script\databaseManifest.txt +save_as !Майнинг.xlsm -> 55 Майнинг.xltm + +%% +# === Install section == +# Available commands: +# install LOCAL_ARTIFACT -> [INSTALL_PATH] +# add_template LOCAL_ARTIFACT -> [LOCAL_TEMPLATE] +# run LOCAL_ARTIFACT.bat <- [PARAMETERS] +# run APPLICATION <- [PARAMETERS] + +install Надстройка\Parsers.dotm -> Надстройка\Parsers.dotm +install !Майнинг.xlsm +install 55 Майнинг.xltm + +install Надстройка\Parsers.dotm -> \\fs1.concept.ru\Exchange\ConceptDistr\data\Add-ins\Word\Parsers.dotm +install models\ActionVerbs.txt -> \\fs1.concept.ru\Exchange\ConceptDistr\models\ActionVerbs.txt +add_template 55 Майнинг.xltm \ No newline at end of file diff --git a/VERSION b/VERSION new file mode 100644 index 0000000..88c5fb8 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +1.4.0 diff --git a/distr/models/ActionVerbs.txt b/distr/models/ActionVerbs.txt new file mode 100644 index 0000000..a72b19c --- /dev/null +++ b/distr/models/ActionVerbs.txt @@ -0,0 +1,463 @@ +аккредитирует +анализирует +аннулирует +апробирует +вводит +ведет +взаимодействует +владеет +внедряет +вносит +возглавляет +возмещает +возобновляет +вступает +входит +выбирает +выдает +выплачивает +выполняет +выражает +выступает +выявляет +голосует +готовит +дает +действует +делегирует +доводит +доставляет +заключает +закрепляет +закрывает +заполняет +запрашивает +запрещает +заслушивает +защищает +заявляет +знакомит +знакомится +избирает +издает +изменяет +изучает +изымает +имеет +инициирует +информирует +исполняет +использует +истребует +комплектует +консультирует +контролирует +координирует +награждает +назначает +налагает +направляет +несет +обеспечивает +обжалует +обладает +обнародует +обобщает +оборудует +образует +обращается +обязывает +ограничивает +одобряет +оказывает +открывает +оповещает +определяет +организовывает +организует +освещает +освобождает +осуществляет +отвечает +отклоняет +открывает +отменяет +отрешает +отстраняет +отчитывается +оформляет +оценивает +передает +переоформляет +перечисляет +планирует +подготавливает +поддерживает +подписывает +получает +пользуется +поощряет +посещает +предлагает +предоставляет +председательствует +представляет +предъявляет +прекращает +привлекает +приглашает +признает +применяет +принимает +приобретает +приостанавливает +присваивает +проверяет +проводит +прогнозирует +продлевает +производит +публикует +развивает +размещает +разрабатывает +разрешает +разъясняет +распоряжается +распределяет +распускает +рассматривает +рассчитывает +расторгает +реализовывает +реализует +регистрирует +регулирует +решает +руководит +санкционирует +совершает +совершенствует +согласовывает +согласует +содействует +содержит +создает +созывает +составляет +способствует +требует +уведомляет +удостоверяет +уполномочивает +управляет +устанавливает +утверждает +участвует +учреждает +формирует +является +аккредитовать +анализировать +аннулировать +апробировать +вводить +вести +взаимодействовать +владеть +внедрять +вносить +возглавлять +возмещать +возобновлять +вступать +входить +выбирать +выдавать +выплачивать +выполнять +выражать +выступать +выявлять +голосовать +готовить +давать +действовать +делегировать +доводить +доставлять +заключать +закреплять +закрывать +заполнять +запрашивать +запрещать +заслушивать +защищать +заявлять +знакомить +знакомиться +избирать +издавать +изменять +изучать +изымать +иметь +инициировать +информировать +исполнять +использовать +истребовать +комплектовать +консультировать +контролировать +координировать +награждать +назначать +налагать +направлять +нести +обеспечивать +обжаловать +обладать +обнародовать +обобщать +оборудовать +образовывать +обращаться +обязывать +ограничивать +одобрять +оказывать +открывать +оповещать +определять +организовывать +организовать +освещать +освобождать +осуществлять +отвечать +отклонять +открывать +отменять +отрешать +отстранять +отчитываться +оформлять +оценивать +передать +переоформлять +перечислять +планировать +подготавливать +поддерживать +подписывать +получать +пользоваться +поощрять +посещать +предлагать +предоставлять +председательствовать +представлять +предъявлять +прекращать +привлекать +приглашать +признать +применять +принимать +приобретать +приостанавливать +присваивать +проверять +проводить +прогнозировать +продлевать +производить +публиковать +развивать +размещать +разрабатывать +разрешать +разъяснять +распоряжаться +распределять +распускать +рассматривать +рассчитывать +расторгать +реализовывать +реализовать +регистрировать +регулировать +решать +руководить +санкционировать +совершать +совершенствовать +согласовывать +согласовать +содействовать +содержать +создавать +созывать +составлять +способствовать +требовать +уведомлять +удостоверять +уполномочивать +управлять +устанавливать +утверждать +участвовать +учреждать +формировать +являться +аккредитация +анализирование +аннулирование +апробирование +введение +ведение +взаимодействие +владение +внедрение +внесение +возглавление +возмещение +возобновление +вступление +вхождение +выбирание +выдавание +выплачивание +выполнение +выражение +выступление +выявление +голосование +дача +действие +делегирование +доведение +доставление +заключение +закрепление +закрывание +заполнение +запрашивание +запрещение +заслушивание +защита +заявление +знакомство +ознакомление +избирание +издание +изменение +изучение +изъятие +имение +иницирование +информирование +исполнение +использование +требование +комплектование +консультирование +контролирование +координирование +награждение +назначение +налагание +направление +несение +обеспечение +обжалование +обладание +обнародование +обобщение +оборудование +обращение +ограничение +одобрение +оказание +открывание +оповещение +определение +освещение +освобождение +осуществление +отвечание +отклонение +открывание +отрешение +отстранение +оформление +передача +переоформление +перечисление +планирование +поддерживание +подписывание +получение +пользование +поощрение +посещение +предложение +предоставление +председательствование +представление +предъявление +прекращение +привлечение +приглашение +признание +применение +приобретение +приостановление +присваивание +проверка +проведение +прогнозирование +продление +производство +публикование +развитие +размещение +разрабатывание +разрешение +разъяснение +распоряжение +распределение +распускание +рассмотрение +расторжение +реализация +регистрирование +регулирование +решение +руководство +санкционирование +совершение +совершенствование +согласование +содействие +содержание +создание +составление +способствование +требование +уведомление +удостоверение +уполномочивание +управление +установление +утверждение +участие +учреждение +формирование +явление \ No newline at end of file diff --git a/script/addinManifest.txt b/script/addinManifest.txt new file mode 100644 index 0000000..9b7cb59 --- /dev/null +++ b/script/addinManifest.txt @@ -0,0 +1,102 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact + +name = Parsers.dotm +artifact = Надстройка\Parsers.dotm + +%% +# === Imports Section === +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SharedHome path + +api + ex_Python.bas + ex_WinAPI.bas + + API_Python.cls + API_Ribbon.cls + API_XLWrapper.cls + API_UserInteraction.cls + +word + ex_Word.bas + +parsers + ParserDeclarations.bas + z_ParserRegex.bas + PC_ParsedData.cls + PC_Fragment.cls + ExtractionOptions.cls + + PC_Tools.cls + DetectorClassifier.cls + DetectorListWords.cls + DetectorRegex.cls + DetectorMorpho.cls + + ParserDate.cls + ParserNPA.cls + + PC_InfoNPA.cls + + +utility + ex_VBA.bas + ex_Regex.bas + ex_DataPreparation.bas + + API_Config.cls + API_JSON.cls + API_Timer.cls + +ui + CSE_ProgressBar.frm + +dev + DevTester.bas + +%% +# === Source Code Section == +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SourceHome path + +src + addin + DevHelper.bas + + Declarations.bas + Main.bas + MainImpl.bas + z_UIRibbon.bas + z_UIMessages.bas + + UIState.cls + IteratorDetected.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 + +%% +# === 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 : MSForms +global : ADODB +global : Excel \ No newline at end of file diff --git a/script/databaseManifest.txt b/script/databaseManifest.txt new file mode 100644 index 0000000..273b2da --- /dev/null +++ b/script/databaseManifest.txt @@ -0,0 +1,82 @@ +# == 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_WordWrapper.cls + API_XLWrapper.cls + API_UserInteraction.cls + +parsers + ParserDeclarations.bas + ExtractionOptions.cls + +utility + ex_VBA.bas + ex_DataPreparation.bas + ex_Version.bas + + API_DistrManifest.cls + API_JSON.cls + API_Timer.cls + +ui + CSE_ProgressBar.frm + +dev + DevTester.bas + +%% +# === Source Code Section == +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SourceHome path + +src + database + ImportDlg.frm + + DevHelper.bas + + Declarations.bas + DataAccess.bas + Main.bas + MainImpl.bas + ManualSubs.bas + z_UIRibbon.bas + z_UIMessages.bas + + test + s_WordInteractions.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 : Word +global : Shell32 +global : Scripting +global : MSForms \ No newline at end of file diff --git a/skeleton/!Майнинг.xlsm b/skeleton/!Майнинг.xlsm new file mode 100644 index 0000000..506a9bc Binary files /dev/null and b/skeleton/!Майнинг.xlsm differ diff --git a/skeleton/Parsers.dotm b/skeleton/Parsers.dotm new file mode 100644 index 0000000..334b340 Binary files /dev/null and b/skeleton/Parsers.dotm differ diff --git a/src/addin/Declarations.bas b/src/addin/Declarations.bas new file mode 100644 index 0000000..656bcbe --- /dev/null +++ b/src/addin/Declarations.bas @@ -0,0 +1,63 @@ +Attribute VB_Name = "Declarations" +Option Private Module +Option Explicit + +Public Const MAX_FIND_LEN = 250 + +Public Const TEMP_FILE_NAME = "conceptParsers" + +' Markup color +Public Enum TColor + [_First] = 1 + + T_COLOR_YELLOW = 1 ' = 7 + T_COLOR_GREEN = 2 ' = 4 + T_COLOR_TEAL = 3 ' = 10 + T_COLOR_GREY = 4 ' = 15 + T_COLOR_BLUE = 5 ' = 9 + + [_Last] = 5 +End Enum + +' _E_ - export +Public Enum ExportStruct + [_First] = 1 + + S_E_ID = 1 + S_E_START = 2 + S_E_FINISH = 3 + S_E_TYPE = 4 + S_E_TEXT = 5 + S_E_DATA = 6 + + [_Last] = 6 +End Enum + +Public Function ColorToStr(iColor As TColor) As String + Select Case iColor + Case T_COLOR_YELLOW: ColorToStr = "" + Case T_COLOR_GREEN: ColorToStr = "" + Case T_COLOR_TEAL: ColorToStr = "" + Case T_COLOR_GREY: ColorToStr = "" + Case T_COLOR_BLUE: ColorToStr = "" + End Select +End Function + +Public Function ColorToColorIndex(iColor As TColor) As Integer + Select Case iColor + Case T_COLOR_YELLOW: ColorToColorIndex = WdColorIndex.wdYellow + Case T_COLOR_GREEN: ColorToColorIndex = WdColorIndex.wdBrightGreen + Case T_COLOR_TEAL: ColorToColorIndex = WdColorIndex.wdTurquoise + Case T_COLOR_GREY: ColorToColorIndex = WdColorIndex.wdGray25 + Case T_COLOR_BLUE: ColorToColorIndex = WdColorIndex.wdBlue + End Select +End Function + +Public Function PTools() As PC_Tools + Static s_Parsers As PC_Tools + If s_Parsers Is Nothing Then + Set s_Parsers = New PC_Tools + End If + Set PTools = s_Parsers +End Function + diff --git a/src/addin/DevHelper.bas b/src/addin/DevHelper.bas new file mode 100644 index 0000000..acf519b --- /dev/null +++ b/src/addin/DevHelper.bas @@ -0,0 +1,20 @@ +Attribute VB_Name = "DevHelper" +Option Explicit + +Public Function Dev_PrepareSkeleton() + Call ThisDocument.Range.Delete +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 + End Select +End Function diff --git a/src/addin/IteratorDetected.cls b/src/addin/IteratorDetected.cls new file mode 100644 index 0000000..f99fa86 --- /dev/null +++ b/src/addin/IteratorDetected.cls @@ -0,0 +1,158 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "IteratorDetected" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' +Option Explicit + +Private Const NO_CURRENT_ID = -1 + +Private selection_ As Word.Range +Private detector_ As Object + +Private start_ As Long +Private data_ As PC_ParsedData +Private currentID_ As Long + +Public Function Init(theDoc As Word.Document, iDetector As Object, Optional nStart& = 0) + Set selection_ = theDoc.Range(nStart, nStart) + Set detector_ = iDetector + + start_ = selection_.Paragraphs.First.Range.Start + Dim sText$: sText = selection_.Paragraphs.First.Range.Text + Set data_ = detector_.ExtractFragments(sText) + currentID_ = IIf(data_.Count = 0, 0, NO_CURRENT_ID) +End Function + +Public Function Range() As Word.Range + Set Range = selection_ +End Function + +Public Function Fragment() As PC_Fragment + If currentID_ <> NO_CURRENT_ID Then _ + Set Fragment = data_.data_.Item(currentID_) +End Function + +Public Function MoveNext() As Word.Range + If currentID_ = NO_CURRENT_ID Then + If Not InitNext Then _ + Exit Function + ElseIf currentID_ = data_.Count Then + If Not NextChunk Then _ + Exit Function + currentID_ = 1 + Else + currentID_ = currentID_ + 1 + End If + + Set selection_ = RangeForFragment(data_.data_.Item(currentID_)) + Set MoveNext = selection_ +End Function + +Public Function MovePrev() As Word.Range + If currentID_ = NO_CURRENT_ID Then + If Not InitPrev Then _ + Exit Function + ElseIf currentID_ <= 1 Then + If Not PrevChunk Then _ + Exit Function + currentID_ = data_.Count + Else + currentID_ = currentID_ - 1 + End If + + Set selection_ = RangeForFragment(data_.data_.Item(currentID_)) + Set MovePrev = selection_ +End Function + +' ====== +Private Function RangeForFragment(iFragment As PC_Fragment) As Word.Range + Dim iRange As Word.Range: Set iRange = selection_.Document.Range(start_, start_) + Call iRange.MoveStart(wdCharacter, iFragment.start_) + Call iRange.Collapse(wdCollapseStart) + Call iRange.MoveEnd(wdCharacter, iFragment.end_ - iFragment.start_) + Set RangeForFragment = iRange +End Function + +Private Function InitNext() As Boolean + Dim nTarget&: nTarget = selection_.End + Dim iRange As Word.Range + Dim nFragment& + For nFragment = 1 To data_.Count Step 1 + Set iRange = RangeForFragment(data_.data_.Item(nFragment)) + If iRange.Start >= nTarget Then + InitNext = True + currentID_ = nFragment + Exit Function + End If + Next nFragment + + If Not NextChunk Then _ + Exit Function + InitNext = True + currentID_ = 1 +End Function + +Private Function InitPrev() As Boolean + Dim nTarget&: nTarget = selection_.Start + Dim iRange As Word.Range + Dim nFragment& + For nFragment = data_.Count To 1 Step -1 + Set iRange = RangeForFragment(data_.data_.Item(nFragment)) + If iRange.End <= nTarget Then + InitPrev = True + currentID_ = nFragment + Exit Function + End If + Next nFragment + + If Not PrevChunk Then _ + Exit Function + InitPrev = True + currentID_ = data_.Count +End Function + +Private Function NextChunk() As Boolean + Dim iRange As Word.Range: Set iRange = selection_.Document.Range(start_, start_) + Dim oldStart& + Do + oldStart = iRange.Start + Call iRange.Move(wdParagraph, 1) + If iRange.Start = oldStart Or iRange.Start + 1 >= selection_.Document.Range.End Then + NextChunk = False + Exit Function + End If + Dim sText$: sText = iRange.Paragraphs.First.Range.Text + Dim iData As PC_ParsedData: Set iData = detector_.ExtractFragments(sText) + If Not iData.IsEmpty Then + NextChunk = True + start_ = iRange.Start + Set data_ = iData + Exit Function + End If + Loop +End Function + +Private Function PrevChunk() As Boolean + Dim iRange As Word.Range: Set iRange = selection_.Document.Range(start_, start_) + Do + If iRange.Start = 0 Then + PrevChunk = False + Exit Function + End If + Call iRange.Move(wdParagraph, -1) + Dim sText$: sText = iRange.Paragraphs.First.Range.Text + Dim iData As PC_ParsedData: Set iData = detector_.ExtractFragments(sText) + If Not iData.IsEmpty Then + PrevChunk = True + start_ = iRange.Start + Set data_ = iData + Exit Function + End If + Loop +End Function diff --git a/src/addin/Main.bas b/src/addin/Main.bas new file mode 100644 index 0000000..697c071 --- /dev/null +++ b/src/addin/Main.bas @@ -0,0 +1,178 @@ +Attribute VB_Name = "Main" +Option Explicit + +Public Function ExportAllData(iParamData() As String) As Variant + Dim oData As New Collection + Dim params As New ExtractionOptions: Call params.FromFlatData(iParamData) + + Dim iDoc As Word.Document: Set iDoc = Word.ActiveDocument + Dim oItem As Collection + + On Error GoTo RETURN_EMPTY + Dim iDetector As Object: Set iDetector = PTools().Detector(params.detector_, params.param_) + Dim oIterator As New IteratorDetected: Call oIterator.Init(iDoc, iDetector) + Do While Not oIterator.MoveNext Is Nothing + Set oItem = New Collection + Call oItem.Add(oIterator.Range.Start) + Call oItem.Add(oIterator.Range.End) + Call oItem.Add(IIf(oIterator.Fragment.type_ <> 0, oIterator.Fragment.type_, params.loadCategory_)) + Call oItem.Add(SubstituteWhitespace(oIterator.Range.Text)) + + Call oData.Add(oItem) + Loop + On Error GoTo 0 + +RETURN_EMPTY: + ExportAllData = ConverToFlat2D(oData) +End Function + +Public Sub RunNextFragment() + Dim rSelection As Word.Range: Set rSelection = Word.Selection.Range + Dim iDetector As Object: Set iDetector = PTools().Detector(GetUIState.detector_, GetUIState.detectionParam_) + Dim oIterator As New IteratorDetected: Call oIterator.Init(rSelection.Document, iDetector, rSelection.End) + If Not oIterator.MoveNext Is Nothing Then + Call oIterator.Range.Select + Else + Call VBA.Beep + End If +End Sub + +Public Sub RunPrevFragment() + Dim rSelection As Word.Range: Set rSelection = Word.Selection.Range + Dim iDetector As Object: Set iDetector = PTools().Detector(GetUIState.detector_, GetUIState.detectionParam_) + Dim oIterator As New IteratorDetected: Call oIterator.Init(rSelection.Document, iDetector, rSelection.Start) + If Not oIterator.MovePrev Is Nothing Then + Call oIterator.Range.Select + Else + Call VBA.Beep + End If +End Sub + +Public Sub RunMarkWord() + Dim iDoc As Word.Document: Set iDoc = Word.ActiveDocument + Dim nCount&: nCount = MarkAllDetected(iDoc, GetUIState.detector_, GetUIState.color_, GetUIState.detectionParam_) + Call iDoc.Application.ScreenRefresh + Call UserInteraction.ShowMessage(IM_MARKDOWN_COMPLETE, nCount) +End Sub + +Public Sub RunMarkParagraph() + Dim iDoc As Word.Document: Set iDoc = Word.ActiveDocument + Dim nCount&: nCount = MarkAllParagraphs(iDoc, GetUIState.detector_, GetUIState.color_, GetUIState.detectionParam_) + Call iDoc.Application.ScreenRefresh + Call UserInteraction.ShowMessage(IM_MARKDOWN_COMPLETE, nCount) +End Sub + +Public Sub RunBrowseFile() + Dim sFile$: sFile = UserInteraction.PromptFileFilter(ActiveDocument.Path & "\", "All files", "*.*") + If sFile = vbNullString Then _ + Exit Sub + + GetUIState.detectionParam_ = sFile + GetUIState.ribbon_.Value.Invalidate +End Sub + +Public Sub RunMorphoParse() + Dim sText$: sText = EnsureSelectedText() + If sText = vbNullString Then _ + Exit Sub + Dim sTags$: sTags = MorphoParse(sText) + Call UserInteraction.ShowMessage(IM_PARSE_MORPHO, sTags) +End Sub + +Public Sub RunContextInfo() + Dim sText$: sText = EnsureSelectedText() + If sText = vbNullString Then _ + Exit Sub + + Dim iDetector As Object: Set iDetector = PTools().Detector(GetUIState.detector_, GetUIState.detectionParam_) + If Not iDetector.Test(sText) Then + Call UserInteraction.ShowMessage(IM_TEST_FAILED, DetectorToStr(GetUIState.detector_)) + Exit Sub + End If + + Dim iParser As Object: Set iParser = PTools().Parser(GetUIState.detector_, GetUIState.detectionParam_) + If iParser Is Nothing Then + Call UserInteraction.ShowMessage(IM_NO_PARSER_DATA, DetectorToStr(GetUIState.detector_)) + Exit Sub + End If + If Not iParser.Parse(sText) Then + Call UserInteraction.ShowMessage(IM_NO_PARSER_DATA, DetectorToStr(GetUIState.detector_)) + Exit Sub + End If + + Call UserInteraction.ShowMessage(IM_PARSED_DESCRIPTION, sText, DetectorToStr(GetUIState.detector_), iParser.GetDataDescription()) +End Sub + +Public Sub RunTransformSingle() + Dim rSelection As Word.Range: Set rSelection = WordAdjustRange(Word.Selection.Range) + Call rSelection.MoveEndWhile(" ", -1) + Dim sText$: sText = VBA.Trim(rSelection.Text) + If sText = vbNullString Then + Call UserInteraction.ShowMessage(EM_SELECTION_EMPTY) + Exit Sub + End If + + Dim iDetector As Object: Set iDetector = PTools().Detector(GetUIState.detector_, GetUIState.detectionParam_) + If Not iDetector.Test(sText) Then + Call UserInteraction.ShowMessage(IM_TEST_FAILED, DetectorToStr(GetUIState.detector_)) + Exit Sub + End If + + Dim iParser As Object: Set iParser = PTools().Parser(GetUIState.detector_, GetUIState.detectionParam_) + If iParser Is Nothing Then _ + Exit Sub + + Dim sNewText$: sNewText = iParser.Transform(sText, GetUIState.transformParam_) + If sText <> sNewText Then _ + rSelection.Text = sNewText + Call rSelection.Select +End Sub + +Public Sub RunTransformAll() + Dim iDoc As Word.Document: Set iDoc = Word.ActiveDocument + + Dim nCount&: nCount = TransformAll(iDoc, GetUIState.GetOptions) + + Call UserInteraction.ShowMessage(IM_TRANSFORM_COMPLETE, nCount) +End Sub + +Public Sub RunExportRanges() + Dim iDoc As Word.Document: Set iDoc = Word.ActiveDocument + + Dim xlApp As New API_XLWrapper + Dim outWB As Excel.Workbook: Set outWB = xlApp.NewDocument + Call xlApp.PauseUI + + Call OutputRanges(iDoc, outWB.Sheets(1), GetUIState.GetOptions) + + Call xlApp.ResumeUI + + Call UserInteraction.ShowMessage(IM_EXPORT_COMPLETE) +End Sub + +Public Sub RunExportAll() + Dim iDoc As Word.Document: Set iDoc = Word.ActiveDocument + + Dim xlApp As New API_XLWrapper + Dim outWB As Excel.Workbook: Set outWB = xlApp.NewDocument + Call xlApp.PauseUI + + Call OutputAllData(iDoc, outWB.Sheets(1), GetUIState.GetOptions) + + Call xlApp.ResumeUI + + Call UserInteraction.ShowMessage(IM_EXPORT_COMPLETE) +End Sub + +Public Sub RunHelp() + MsgBox "TODO" +End Sub + +' ====== +Private Function EnsureSelectedText() As String + Dim rSelection As Word.Range: Set rSelection = WordAdjustRange(Word.Selection.Range) + Dim sText$: sText = VBA.Trim(rSelection.Text) + If sText = vbNullString Then _ + Call UserInteraction.ShowMessage(EM_SELECTION_EMPTY) + EnsureSelectedText = sText +End Function diff --git a/src/addin/MainImpl.bas b/src/addin/MainImpl.bas new file mode 100644 index 0000000..3c0221a --- /dev/null +++ b/src/addin/MainImpl.bas @@ -0,0 +1,174 @@ +Attribute VB_Name = "MainImpl" +Option Explicit + +Public Function MarkAllDetected(iDoc As Word.Document, nDetector As TDetector, iColor As TColor, sParam$) As Long + Dim nColor&: nColor = ColorToColorIndex(iColor) + Dim iDetector As Object: Set iDetector = PTools().Detector(nDetector, sParam) + Dim oIterator As New IteratorDetected: Call oIterator.Init(iDoc, iDetector) + Dim iRange As Word.Range + Dim fragmentColor& + Dim nCount&: nCount = 0 + Do + Set iRange = oIterator.MoveNext + If iRange Is Nothing Then _ + Exit Do + + Dim nType&: nType = oIterator.Fragment.type_ + fragmentColor = IIf(nType = 0, 0, ColorToColorIndex(TColor.[_First] + ((nType - 1) Mod TColor.[_Last]))) + If nCount = 0 Then + Dim oldColor&: oldColor = iRange.HighlightColorIndex + If oldColor = nColor Or (oldColor = fragmentColor And fragmentColor <> 0) Then _ + nColor = wdAuto + End If + If nColor <> wdAuto And fragmentColor <> 0 Then _ + nColor = fragmentColor + iRange.HighlightColorIndex = nColor + nCount = nCount + 1 + Loop + MarkAllDetected = nCount +End Function + +Public Function MarkAllParagraphs(iDoc As Word.Document, nDetector As TDetector, iColor As TColor, sParam$) As Long + Dim nColor&: nColor = ColorToColorIndex(iColor) + Dim iDetector As Object: Set iDetector = PTools().Detector(nDetector, sParam) + Dim oIterator As New IteratorDetected: Call oIterator.Init(iDoc, iDetector) + Dim iRange As Word.Range + Dim nCount&: nCount = 0 + Dim oldStart&: oldStart = -1 + Do + Set iRange = oIterator.MoveNext + If iRange Is Nothing Then _ + Exit Do + If nCount = 0 And iRange.HighlightColorIndex = nColor Then _ + nColor = wdAuto + iRange.Paragraphs.First.Range.HighlightColorIndex = nColor + If oldStart <> iRange.Start Then + oldStart = iRange.Start + nCount = nCount + 1 + End If + Loop + MarkAllParagraphs = nCount +End Function + +Public Function MorphoParse(sText$) As String + MorphoParse = AccessPython.CallFunction(PY_MODULE_TEXT, "parse", Array(sText, "")) +End Function + +Public Function ConverToFlat2D(oData As Collection) As Variant + Dim iData() As Variant + If oData.Count = 0 Then + ConverToFlat2D = iData + Exit Function + End If + + ReDim iData(0 To oData.Count - 1, 0 To oData.Item(1).Count - 1) + Dim nRow&: nRow = 0 + Dim oItem As Object + Dim vElement As Variant + For Each oItem In oData + Dim nCol&: nCol = 0 + For Each vElement In oItem + iData(nRow, nCol) = vElement + nCol = nCol + 1 + Next vElement + nRow = nRow + 1 + Next oItem + + ConverToFlat2D = iData +End Function + +Public Function TransformAll(iDoc As Word.Document, iOptions As ExtractionOptions) As Long + Dim iParser As Object: Set iParser = PTools().Parser(iOptions.detector_, iOptions.param_) + If iParser Is Nothing Then _ + Exit Function + Dim iDetector As Object: Set iDetector = PTools().Detector(iOptions.detector_, iOptions.param_) + Dim oIterator As New IteratorDetected: Call oIterator.Init(iDoc, iDetector, iDoc.Range.End - 1) + + Dim nCount&: nCount = 0 + Do While Not oIterator.MovePrev Is Nothing + Dim sText$: sText = oIterator.Range.Text + Dim sNewText$: sNewText = iParser.Transform(sText, iOptions.transform_) + If sText <> sNewText Then + oIterator.Range.Text = sNewText + Call oIterator.Init(iDoc, iDetector, oIterator.Range.Start) + nCount = nCount + 1 + End If + Loop + TransformAll = nCount +End Function + +Public Function OutputRanges(iSource As Word.Document, wsOut As Excel.Worksheet, iOptions As ExtractionOptions) + Dim iDetector As Object: Set iDetector = PTools().Detector(iOptions.detector_, iOptions.param_) + Dim oIterator As New IteratorDetected: Call oIterator.Init(iSource, iDetector) + + With wsOut + .Cells(1, S_E_ID) = "ID" + .Cells(1, S_E_START) = "" + .Cells(1, S_E_FINISH) = "" + .Cells(1, S_E_TYPE) = "" + End With + + Dim nRow&: nRow = 2 + Do While Not oIterator.MoveNext Is Nothing + With wsOut + .Cells(nRow, S_E_ID) = nRow - 1 + .Cells(nRow, S_E_START) = oIterator.Range.Start + .Cells(nRow, S_E_FINISH) = oIterator.Range.End + .Cells(nRow, S_E_TYPE) = IIf(oIterator.Fragment.type_ = 0, iOptions.loadCategory_, oIterator.Fragment.type_) + End With + nRow = nRow + 1 + Loop +End Function + +Public Function OutputAllData(iSource As Word.Document, wsOut As Excel.Worksheet, iOptions As ExtractionOptions) + Dim iDetector As Object: Set iDetector = PTools().Detector(iOptions.detector_, iOptions.param_) + Dim iParser As Object: Set iParser = PTools().Parser(iOptions.detector_, iOptions.param_) + Dim oIterator As New IteratorDetected: Call oIterator.Init(iSource, iDetector) + + With wsOut + .Cells(1, S_E_ID) = "ID" + .Cells(1, S_E_START) = "" + .Cells(1, S_E_FINISH) = "" + .Cells(1, S_E_TYPE) = "" + .Cells(1, S_E_TEXT) = "" + End With + + Dim nRow&: nRow = 2 + Dim iData As Collection + Do While Not oIterator.MoveNext Is Nothing + Dim sText$: sText = oIterator.Range.Text + With wsOut + .Cells(nRow, 1) = nRow - 1 + .Cells(nRow, 2) = oIterator.Range.Start + .Cells(nRow, 3) = oIterator.Range.End + .Cells(nRow, 4) = IIf(oIterator.Fragment.type_ = 0, iOptions.loadCategory_, oIterator.Fragment.type_) + .Cells(nRow, 5) = sText + End With + If iParser Is Nothing Then _ + GoTo NEXT_ROW + If Not iParser.Parse(sText) Then _ + GoTo NEXT_ROW + Set iData = iParser.GetData() + If iData.Count = 0 Then _ + GoTo NEXT_ROW + + Dim nCol&: nCol = S_E_DATA + Dim vItem As Variant + For Each vItem In iData + wsOut.Cells(nRow, nCol) = vItem + nCol = nCol + 1 + Next vItem + + If nRow <> 2 Then _ + GoTo NEXT_ROW + Dim iHeader As Scripting.Dictionary: Set iHeader = iParser.GetDataDescription() + nCol = S_E_DATA + For Each vItem In iHeader.Keys + wsOut.Cells(1, nCol) = vItem + nCol = nCol + 1 + Next vItem + +NEXT_ROW: + nRow = nRow + 1 + Loop +End Function diff --git a/src/addin/ManualSubs.bas b/src/addin/ManualSubs.bas new file mode 100644 index 0000000..5f4098d --- /dev/null +++ b/src/addin/ManualSubs.bas @@ -0,0 +1,29 @@ +Attribute VB_Name = "ManualSubs" +Option Explicit + +'Public Function P_GetNPAFromActive() As Long() +' Dim frags As New PC_ParsedData +' Dim npaRegex As RegExp: Set npaRegex = GlobalNPARegex +' +' Dim aPar As Word.Paragraph +' Dim parRng As Word.Range +' Dim matches As Object +' Dim nMatch& +' For Each aPar In ActiveDocument.Paragraphs +' Set parRng = aPar.Range +' Dim sTxt$: sTxt = FixSpecialSymbols(parRng.Text) +' Set matches = npaRegex.Execute(sTxt) +' For nMatch = 1 To matches.Count Step 1 +' Dim findRng As Word.Range: Set findRng = parRng.Duplicate +' Call findRng.MoveStart(wdCharacter, InStr(1, sTxt, matches.Item(nMatch - 1).SubMatches(0))) +' Call findRng.Collapse(wdCollapseStart) +' Call findRng.MoveEnd(wdCharacter, Len(matches.Item(nMatch - 1).SubMatches(0))) +' Call frags.AddItem(findRng.Start, findRng.End, 0) +' Next nMatch +' Next aPar +' +' If frags.data_.Count > 0 Then _ +' P_GetNPAFromActive = frags.AsFlatData +'End Function +' +' diff --git a/src/addin/UIState.cls b/src/addin/UIState.cls new file mode 100644 index 0000000..b8d9e7e --- /dev/null +++ b/src/addin/UIState.cls @@ -0,0 +1,38 @@ +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 ribbon_ As API_Ribbon + +Public detector_ As TDetector +Public detectionParam_ As String + +Public color_ As TColor + +Public transformParam_ As String + +Public category_ As Long + +Private Sub Class_Initialize() + detector_ = T_DETECTOR_REGEX + color_ = T_COLOR_YELLOW + transformParam_ = vbNullString + detectionParam_ = vbNullString + category_ = 0 + Set ribbon_ = New API_Ribbon +End Sub + +Public Function GetOptions() As ExtractionOptions + Set GetOptions = New ExtractionOptions + GetOptions.detector_ = detector_ + GetOptions.param_ = detector_ + GetOptions.transform_ = transformParam_ + GetOptions.loadCategory_ = category_ +End Function diff --git a/src/addin/z_UIMessages.bas b/src/addin/z_UIMessages.bas new file mode 100644 index 0000000..7a03ad2 --- /dev/null +++ b/src/addin/z_UIMessages.bas @@ -0,0 +1,85 @@ +Attribute VB_Name = "z_UIMessages" +' Messaging module +Option Private Module +Option Explicit + +Public Enum MsgCode + ' EM_COMBO_TAKEN = ERR_COMBO_TAKEN + + EM_RIBBON_NOT_REACHABLE = 1 + EM_SELECTION_EMPTY + + IM_MARKDOWN_COMPLETE + IM_PARSE_MORPHO + IM_NO_PARSER_DATA + IM_TEST_FAILED + IM_PARSED_DESCRIPTION + IM_EXPORT_COMPLETE + IM_TRANSFORM_COMPLETE + + ' QM_CONFIG_EDIT_CONFIRM +End Enum + +Private g_UI As API_UserInteraction + +Public Function UserInteraction() As API_UserInteraction + If g_UI Is Nothing Then _ + Set g_UI = New API_UserInteraction + Set UserInteraction = g_UI +End Function + +Public Function SetUserInteraction(newUI As API_UserInteraction) + Set g_UI = newUI +End Function + +Public Function ProcessErrorMessages(expectedErrors As Scripting.Dictionary) + If Err.Number = 0 Then _ + Exit Function + + Call Unload(CSE_ProgressBar) + If Not expectedErrors.Exists(Err.Number) Then _ + Call Err.Raise(Err.Number) + + Call UserInteraction.ShowMessage(Err.Number, Err.Source) +End Function + +Public Function UIShowMessage(theCode As MsgCode, ParamArray params() As Variant) + Dim unwrapped As Variant: unwrapped = params + unwrapped = FixForwardedParams(unwrapped) + + Select Case theCode + Case EM_RIBBON_NOT_REACHABLE + Call MsgBox(" !" & vbNewLine & _ + ", Word ", vbExclamation) + Case EM_SELECTION_EMPTY: Call MsgBox(" ", vbExclamation) + + Case IM_MARKDOWN_COMPLETE: Call MsgBox(Fmt(" : {1}", unwrapped), vbInformation) + Case IM_PARSE_MORPHO: Call MsgBox(Fmt(" : {1}", unwrapped), vbInformation) + Case IM_NO_PARSER_DATA: Call MsgBox(Fmt(" : {1}", unwrapped), vbInformation) + Case IM_TEST_FAILED: Call MsgBox(Fmt(" : {1}", unwrapped), vbInformation) + Case IM_EXPORT_COMPLETE: Call MsgBox(" ", vbInformation) + Case IM_TRANSFORM_COMPLETE: Call MsgBox(Fmt(" : {1}", unwrapped), vbInformation) + + Case IM_PARSED_DESCRIPTION: Call MsgBox(Fmt(" : {1}" & vbNewLine & _ + " : {2}" & vbNewLine & _ + " " & vbNewLine & "{3}", unwrapped), vbInformation) + + Case Else: Call MsgBox(" ", vbCritical) + End Select +End Function + +Public Function UIAskQuestion(theCode As MsgCode, ParamArray params() As Variant) As Boolean + Dim unwrapped As Variant: unwrapped = params + unwrapped = FixForwardedParams(unwrapped) + + Dim answer&: answer = vbNo + Select Case theCode + ' Case QM_CONFIG_EDIT_CONFIRM + ' answer = MsgBox("! . " & _ + ' vbNewLine & " ", vbYesNo + vbQuestion) + + Case Else + Call MsgBox("Invalid message code", vbCritical) + End Select + UIAskQuestion = answer = vbYes +End Function diff --git a/src/addin/z_UIRibbon.bas b/src/addin/z_UIRibbon.bas new file mode 100644 index 0000000..3f3b0ab --- /dev/null +++ b/src/addin/z_UIRibbon.bas @@ -0,0 +1,117 @@ +Attribute VB_Name = "z_UIRibbon" +' +Option Explicit + +Global g_UIState As UIState + +Public Function GetUIState() As UIState + If g_UIState Is Nothing Then + Set g_UIState = New UIState + Call g_UIState.ribbon_.LoadFrom(RibbonTempFile) +' Call UIUpdateConfigList + End If + Set GetUIState = g_UIState + If g_UIState.ribbon_.Value Is Nothing Then _ + Call UserInteraction.ShowMessage(EM_RIBBON_NOT_REACHABLE) +End Function + +Public Sub Parse_LoadRibbon(aRibbon As IRibbonUI) + Set g_UIState = New UIState + Call g_UIState.ribbon_.Init(aRibbon, RibbonTempFile) + 'Call UIUpdateConfigList +End Sub + +Public Sub Parse_OnBtn(iControl As IRibbonControl) + Call EnsureGlobalState + Select Case iControl.ID + Case "NextFragment": Call RunNextFragment + Case "PrevFragment": Call RunPrevFragment + Case "BrowseFile": Call RunBrowseFile + Case "MorphoParse": Call RunMorphoParse + Case "ContextInfo": Call RunContextInfo + + Case "MarkWord": Call RunMarkWord + Case "MarkParagraph": Call RunMarkParagraph + + Case "TransformSingle": Call RunTransformSingle + Case "TransformAll": Call RunTransformAll + + Case "ExportAll": Call RunExportAll + Case "ExportRanges": Call RunExportRanges + + Case "ViewHelp": Call RunHelp + End Select +End Sub + +Public Function ParseUI_DetectorCount(iControl As IRibbonControl, ByRef nCount) + nCount = TDetector.[_Last] +End Function + +Public Function ParseUI_DetectorLabel(iControl As IRibbonControl, nIndex%, ByRef vLabel) + vLabel = DetectorToStr(nIndex + 1) +End Function + +Public Function ParseUI_DetectorGetSelectedIndex(iControl As IRibbonControl, ByRef nValue) + Call EnsureGlobalState + nValue = g_UIState.detector_ - 1 +End Function + +Public Function ParseUI_DetectorChange(iControl As IRibbonControl, sID$, nIndex As Variant) + Call EnsureGlobalState + g_UIState.detector_ = nIndex + 1 + ' Do any UI updates needed on entity switch +End Function + +Public Function ParseUI_ParamText(iControl As IRibbonControl, ByRef vLabel) + vLabel = GetUIState.detectionParam_ +End Function + +Public Function ParseUI_ParamChange(iControl As IRibbonControl, sParam$) + Call EnsureGlobalState + g_UIState.detectionParam_ = sParam +End Function + +Public Function ParseUI_TransformText(iControl As IRibbonControl, ByRef vLabel) + vLabel = GetUIState.transformParam_ +End Function + +Public Function ParseUI_TransformChange(iControl As IRibbonControl, sParam$) + Call EnsureGlobalState + g_UIState.transformParam_ = sParam +End Function + +Public Function ParseUI_CategoryText(iControl As IRibbonControl, ByRef vLabel) + vLabel = GetUIState.category_ +End Function + +Public Function ParseUI_CategoryChange(iControl As IRibbonControl, sParam$) + Call EnsureGlobalState + g_UIState.category_ = sParam +End Function + +Public Function ParseUI_MarkupCount(iControl As IRibbonControl, ByRef nCount) + nCount = TColor.[_Last] +End Function + +Public Function ParseUI_MarkupLabel(iControl As IRibbonControl, nIndex%, ByRef vLabel) + vLabel = ColorToStr(nIndex + 1) +End Function + +Public Function ParseUI_MarkupGetSelectedIndex(iControl As IRibbonControl, ByRef nValue) + Call EnsureGlobalState + nValue = g_UIState.color_ - 1 +End Function + +Public Function ParseUI_MarkupChange(iControl As IRibbonControl, sID$, nIndex As Variant) + Call EnsureGlobalState + g_UIState.color_ = nIndex + 1 +End Function + +' ============= +Private Function EnsureGlobalState() As Boolean + EnsureGlobalState = Not GetUIState Is Nothing +End Function + +Private Function RibbonTempFile() As String + RibbonTempFile = Environ("TEMP") & "/" & TEMP_FILE_NAME & CStr(GetCurrentProcessId) & ".txt" +End Function diff --git a/src/database/DataAccess.bas b/src/database/DataAccess.bas new file mode 100644 index 0000000..16299f8 --- /dev/null +++ b/src/database/DataAccess.bas @@ -0,0 +1,66 @@ +Attribute VB_Name = "DataAccess" +Option Explicit +Option Private Module + +' TODO: incapsulate into DB class + +Private Const SHEET_SOURCE = "" +Private Const SHEET_DATA = "" + +Public Function DataSheet() As Excel.Worksheet + Set DataSheet = ThisWorkbook.Sheets(SHEET_DATA) +End Function + +Public Function SourceSheet() As Excel.Worksheet + Set SourceSheet = ThisWorkbook.Sheets(SHEET_SOURCE) +End Function + +Public Function AddSource(target As Word.Document) As Long + AddSource = SourceSheet.Cells(GetRowFor(target.FullName), SS_ID) +End Function + +Public Function SourceFileFor(sourceID&) As String + Dim foundRng As Excel.Range + Set foundRng = SourceSheet.Columns(SS_ID).Find(sourceID, LookAt:=xlWhole) + If foundRng Is Nothing Then _ + Exit Function + + SourceFileFor = SourceSheet.Cells(foundRng.Row, SS_PATH) +End Function + +Public Function RowFor(sourceID&) As Long + Dim foundRng As Excel.Range + Set foundRng = SourceSheet.Columns(SS_ID).Find(sourceID, LookAt:=xlWhole) + If foundRng Is Nothing Then _ + Exit Function + + RowFor = foundRng.Row +End Function + +' ==== +Private Function GetNextID() As Long + Dim docsSht As Excel.Worksheet: Set docsSht = SourceSheet + Dim nRow&: nRow = DEFAULT_FIRST_ROW + Dim theID&: theID = 1 + Do While docsSht.Cells(nRow, SS_ID) <> vbNullString + If theID >= docsSht.Cells(nRow, SS_ID) Then _ + theID = docsSht.Cells(nRow, SS_ID) + 1 + nRow = nRow + 1 + Loop + GetNextID = theID +End Function + +Private Function GetRowFor(target$) As Long + Dim theSheet As Excel.Worksheet: Set theSheet = SourceSheet + Dim foundRng As Excel.Range + Set foundRng = theSheet.Columns(SS_PATH).Find(target, LookAt:=xlWhole) + If foundRng Is Nothing Then + Dim nRow&: nRow = theSheet.Columns(SS_ID).Find(vbNullString, LookAt:=xlWhole).Row + theSheet.Cells(nRow, SS_ID) = GetNextID + theSheet.Cells(nRow, SS_PATH) = target + Call theSheet.Cells(nRow, SS_PATH).Hyperlinks.Add(theSheet.Cells(nRow, SS_PATH), target) + GetRowFor = nRow + Else + GetRowFor = foundRng.Row + End If +End Function diff --git a/src/database/Declarations.bas b/src/database/Declarations.bas new file mode 100644 index 0000000..b662fd5 --- /dev/null +++ b/src/database/Declarations.bas @@ -0,0 +1,38 @@ +Attribute VB_Name = "Declarations" +Option Explicit +Option Private Module + +' +Public Enum DataStruct + [_First] = 1 + + DS_ID = 1 + DS_START = 2 + DS_END = 3 + DS_TYPE = 4 + DS_TEXT = 5 + + [_Last] = 5 +End Enum + +' +Public Enum SourceStruct + [_First] = 1 + + SS_ID = 1 + SS_PATH = 2 + SS_NAME = 3 + SS_PARS = 4 + SS_TIME = 5 + SS_COUNT = 6 + + [_Last] = 6 +End Enum + +Public Const FUNC_PARSE = "ExportAllData" + +Public Const ADDIN_FILENAME = "Parsers.dotm" +Public Const DOC_MASK = "*.doc*" + +Public Const DEFAULT_FIRST_ROW = 2 +Public Const INVALID_ROW = -1 diff --git a/src/database/DevHelper.bas b/src/database/DevHelper.bas new file mode 100644 index 0000000..fdcc60f --- /dev/null +++ b/src/database/DevHelper.bas @@ -0,0 +1,50 @@ +Attribute VB_Name = "DevHelper" +Option Explicit + +Private Const TEST_BASIC_PARSE = "TestBasic.docx" +Private Const ADDIN_FILE = "Parsers.dotm" + +Private g_RemoveAddin As Boolean + +Public Function Dev_PrepareSkeleton() + Call ClearAll +End Function + +Public Sub Dev_ManualRunTest() + Dim sSuite$: sSuite = "s_WordInteractions" + Dim sTest$: sTest = "t_ImportDates" + 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_WordInteractions": Set Dev_GetTestSuite = New s_WordInteractions + End Select +End Function + +Public Function GetTestFile() As String + Dim fso As New Scripting.FileSystemObject + GetTestFile = ThisWorkbook.Path & "\test\" & TEST_BASIC_PARSE +End Function + +Public Function SetupTestAddin() + Dim fso As New Scripting.FileSystemObject + Dim sLocal$: sLocal = ThisWorkbook.Path & "\\" & ADDIN_FILE + Dim sAppAddin$: sAppAddin = GetGlobalAddin + g_RemoveAddin = Not fso.FileExists(sAppAddin) + Call CopyFileOrFolder(sLocal, sAppAddin, fso) +End Function + +Public Function TeardownTestAddin() + Dim fso As New Scripting.FileSystemObject + On Error Resume Next + If g_RemoveAddin Then _ + Call fso.DeleteFile(GetGlobalAddin) +End Function + +' ====== +Private Function GetGlobalAddin() As String + GetGlobalAddin = VBA.Environ$("APPDATA") & "\Microsoft\Word\STARTUP\" & ADDIN_FILE +End Function diff --git a/src/database/ImportDlg.frm b/src/database/ImportDlg.frm new file mode 100644 index 0000000..028e365 --- /dev/null +++ b/src/database/ImportDlg.frm @@ -0,0 +1,92 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} ImportDlg + Caption = " " + ClientHeight = 2805 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 6780 + OleObjectBlob = "ImportDlg.frx":0000 + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "ImportDlg" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Explicit + +Public isCancelled_ As Boolean +Public isFolder_ As Boolean + +Private Sub UserForm_Initialize() + Dim nType As TDetector + For nType = TDetector.[_First] To TDetector.[_Last] + Call CBType.AddItem(DetectorToStr(nType)) + Next nType + + isFolder_ = False + isCancelled_ = True + TBCategory.Value = 0 +End Sub + +Private Sub UserForm_Terminate() + isCancelled_ = True + Call Me.Hide +End Sub + +Public Property Get FileName() As String + FileName = TBDocument.Text +End Property + +Public Property Get Options() As ExtractionOptions + Set Options = New ExtractionOptions + Options.detector_ = CBType.ListIndex + 1 + Options.param_ = TBParam.Text + Options.transform_ = TBTransform.Text + Options.loadCategory_ = TBCategory.Value +End Property + +' ============ +Private Sub DocumentBtn_Click() + Dim sFile$: sFile = UserInteraction.PromptFileFilter( _ + ThisWorkbook.Path & "\", _ + sDescription:=" Word", _ + sFilter:="*.docx;*.doc;*.docm") + If sFile = vbNullString Then _ + Exit Sub + isFolder_ = False + TBDocument.Text = sFile +End Sub + +Private Sub ParameterBtn_Click() +Dim sFile$: sFile = UserInteraction.PromptFileFilter( _ + ThisWorkbook.Path & "\", _ + "All files", _ + "*.*") + If sFile = vbNullString Then _ + Exit Sub + TBParam.Text = sFile +End Sub + +Private Sub FolderBtn_Click() + Dim sFile$: sFile = UserInteraction.PromptFolder(ThisWorkbook.Path & "\") + If sFile = vbNullString Then _ + Exit Sub + isFolder_ = True + TBDocument.Text = sFile +End Sub + +Private Sub CancelBtn_Click() + isCancelled_ = True + Call Me.Hide +End Sub + +Private Sub OkBtn_Click() + If FileName = vbNullString Or CBType.ListIndex = -1 Then + Call UserInteraction.ShowMessage(EM_VALIDATION_FAIL) + Exit Sub + End If + + isCancelled_ = False + Call Me.Hide +End Sub diff --git a/src/database/ImportDlg.frx b/src/database/ImportDlg.frx new file mode 100644 index 0000000..d19dbe3 Binary files /dev/null and b/src/database/ImportDlg.frx differ diff --git a/src/database/Main.bas b/src/database/Main.bas new file mode 100644 index 0000000..aa9b7c2 --- /dev/null +++ b/src/database/Main.bas @@ -0,0 +1,62 @@ +Attribute VB_Name = "Main" +Option Explicit +Option Private Module + +Public Const PRODUCT_VERSION = "1.3.0" +Public Const PRODUCT_NAME = "Concept-Mining" + +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 RunImportWord() + If Not EnsureAddinInstalled Then _ + Exit Sub + + Call ImportDlg.Show + If ImportDlg.isCancelled_ Then + Unload ImportDlg + Exit Sub + End If + + Dim iParams As ExtractionOptions: Set iParams = ImportDlg.Options + Dim sPath$: sPath = ImportDlg.FileName + Dim bIsFolder As Boolean: bIsFolder = ImportDlg.isFolder_ + Call Unload(ImportDlg) + + Dim nCount&: nCount = ProcessImports(sPath, bIsFolder, iParams) + + Call UserInteraction.ShowMessage(IM_IMPORT_COMPLETE, nCount) +End Sub + +Public Sub RunFollowLink() + Dim theSheet As Excel.Worksheet: Set theSheet = DataSheet + If ThisWorkbook.ActiveSheet.Name <> theSheet.Name Then + Call UserInteraction.ShowMessage(EM_EXPECTED_DATASHEET) + Exit Sub + End If + + Dim nRow&: nRow = ThisWorkbook.Application.Selection.Cells(1, 1).Row + Dim srcID$: srcID = theSheet.Cells(nRow, DS_ID) + If srcID = vbNullString Or Not IsNumeric(srcID) Then + Call UserInteraction.ShowMessage(EM_INVALID_SOURCE_ID) + Exit Sub + End If + Call FollowLinkAt(CLng(srcID), theSheet.Cells(nRow, DS_START), theSheet.Cells(nRow, DS_END)) +End Sub + +Public Sub RunClearAll() + Call ClearAll + Call UserInteraction.ShowMessage(IM_CLEAR_ALL) +End Sub diff --git a/src/database/MainImpl.bas b/src/database/MainImpl.bas new file mode 100644 index 0000000..072e5fe --- /dev/null +++ b/src/database/MainImpl.bas @@ -0,0 +1,152 @@ +Attribute VB_Name = "MainImpl" +Option Explicit +Option Private Module + +Public Function EnsureAddinInstalled() As Boolean + Dim sPath$: sPath = Environ("APPDATA") & "\Microsoft\Word\STARTUP\" & ADDIN_FILENAME + Dim fso As New Scripting.FileSystemObject + EnsureAddinInstalled = fso.FileExists(sPath) + If Not EnsureAddinInstalled Then _ + Call UserInteraction.ShowMessage(EM_NO_ADDIN) +End Function + +Public Function ClearAll() + SourceSheet.UsedRange.Offset(1).ClearContents + DataSheet.UsedRange.Offset(1).ClearContents +End Function + +Private Function ScanDocsFolder(target$) As Collection + Set ScanDocsFolder = New Collection + + Dim sFolder$: sFolder = target & "\" + Dim sFile$: sFile = Dir(sFolder & DOC_MASK) + Do While Len(sFile) > 0 And sFile <> sFolder + Call ScanDocsFolder.Add(sFolder & sFile) + sFile = Dir + Loop +End Function + +Public Function ProcessImports(sPath$, bIsFolder As Boolean, params As ExtractionOptions, Optional bSilent As Boolean = False) As Long + Dim wordApp As New API_WordWrapper: Call wordApp.CreateApplication(bIsVisible:=False) + If bSilent Then _ + Call wordApp.DisableMessages + + Dim xlUI As New API_XLWrapper: Call xlUI.SetApplication(ThisWorkbook.Application) + Call xlUI.PauseUI + ThisWorkbook.Application.DisplayAlerts = False + + Dim nCount&: nCount = 0 + Dim theDoc As Word.Document + If Not bIsFolder Then + Set theDoc = wordApp.OpenDocument(sPath, bReadOnly:=True) + If theDoc Is Nothing Then _ + GoTo SAFE_EXIT + nCount = nCount + ScanDataFrom(wordApp, params) + Call wordApp.ReleaseDocument + Else + Dim docs As Collection: Set docs = ScanDocsFolder(sPath) + Call CSE_ProgressBar.Init(" ", maxVal:=docs.Count - 1, canInterrupt:=True) + If Not bSilent Then _ + Call CSE_ProgressBar.Show + + Dim sFile As Variant + For Each sFile In docs + Set theDoc = wordApp.OpenDocument(CStr(sFile), bReadOnly:=True) + If theDoc Is Nothing Then _ + GoTo SAFE_EXIT + + theDoc.Range.NoProofing = True + + CSE_ProgressBar.Description = theDoc.Name + nCount = nCount + ScanDataFrom(wordApp, params) + Call wordApp.ReleaseDocument(bCloseApplication:=False) + + Call CSE_ProgressBar.IncrementA + If CSE_ProgressBar.Interrupted Then _ + Exit For + Next sFile + + Call Unload(CSE_ProgressBar) + End If + +SAFE_EXIT: + ThisWorkbook.Application.DisplayAlerts = True + Call xlUI.ResumeUI + Call wordApp.ReleaseApplication + ProcessImports = nCount +End Function + +Public Function FollowLinkAt(target&, nStart&, nEnd&) + Dim sPath$: sPath = SourceFileFor(target) + If sPath = vbNullString Then + Call UserInteraction.ShowMessage(EM_INVALID_SOURCE_ID) + Exit Function + End If + + Dim fso As New Scripting.FileSystemObject + If Not fso.FileExists(sPath) Then + Call UserInteraction.ShowMessage(EM_INVALID_PATH, sPath) + Exit Function + End If + + Dim wordApp As New API_WordWrapper + Dim theDoc As Word.Document: Set theDoc = wordApp.OpenDocument(sPath) + If theDoc Is Nothing Then _ + Exit Function + + If theDoc.Range.End < nEnd Then + Call UserInteraction.ShowMessage(EM_INVALID_LINK, sPath) + Exit Function + End If + + Dim targetRng As Word.Range: Set targetRng = theDoc.Range(nStart, nEnd) + Call targetRng.Select + Call theDoc.ActiveWindow.ScrollIntoView(targetRng) + + Call wordApp.Application.Activate +End Function + +' ====== +Private Function ScanDataFrom(target As API_WordWrapper, params As ExtractionOptions) As Long + Dim dataSht As Excel.Worksheet: Set dataSht = DataSheet + Dim srcSht As Excel.Worksheet: Set srcSht = SourceSheet + Dim theTimer As New API_Timer + + Call theTimer.Start + Call target.Document.Activate + + Dim srcID&: srcID = AddSource(target.Document) + Dim srcRow: srcRow = RowFor(srcID) + Dim nCount&: nCount = 0 + Dim newData As Variant + + Call target.Document.Activate + On Error GoTo EXIT_FUNCTION + newData = target.Run(FUNC_PARSE, params.AsFlatData) + On Error GoTo 0 + If ArraySize(newData) <= 0 Then _ + Exit Function + + Dim nRow&: nRow = dataSht.Columns(DS_ID).Find(vbNullString, LookAt:=xlWhole).Row + Dim nDataRow& + Dim nDataCol& + For nDataRow = LBound(newData, 1) To UBound(newData, 1) Step 1 + dataSht.Cells(nRow, DS_ID) = srcID + Dim nCol&: nCol = DS_ID + 1 + For nDataCol = LBound(newData, 2) To UBound(newData, 2) Step 1 + dataSht.Cells(nRow, nCol) = newData(nDataRow, nDataCol) + nCol = nCol + 1 + Next nDataCol + + nRow = nRow + 1 + nCount = nCount + 1 + Next nDataRow + + srcSht.Cells(srcRow, SS_TIME) = theTimer.TimeElapsed + srcSht.Cells(srcRow, SS_COUNT) = nCount + srcSht.Cells(srcRow, SS_NAME) = target.Document.Name + srcSht.Cells(srcRow, SS_PARS) = target.Document.Paragraphs.Count + +EXIT_FUNCTION: + ScanDataFrom = nCount +End Function diff --git a/src/database/ManualSubs.bas b/src/database/ManualSubs.bas new file mode 100644 index 0000000..30bef38 --- /dev/null +++ b/src/database/ManualSubs.bas @@ -0,0 +1,6 @@ +Attribute VB_Name = "ManualSubs" +Option Explicit + +Public Sub RunClear() + Call ClearAll +End Sub diff --git a/src/database/z_UIMessages.bas b/src/database/z_UIMessages.bas new file mode 100644 index 0000000..4f19bdf --- /dev/null +++ b/src/database/z_UIMessages.bas @@ -0,0 +1,69 @@ +Attribute VB_Name = "z_UIMessages" +' Messaging module +Option Private Module +Option Explicit + +Public Enum MsgCode + MSG_OK = 0 + + EM_EXPECTED_DATASHEET + EM_NO_ADDIN + EM_INVALID_SOURCE_ID + EM_INVALID_PATH + EM_INVALID_LINK + EM_VALIDATION_FAIL + + IM_IMPORT_COMPLETE + IM_CLEAR_ALL + + 'QM_ADD_TITLELINK +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_EXPECTED_DATASHEET: Call MsgBox(" """"", vbExclamation) + Case EM_NO_ADDIN: Call MsgBox("! Word", vbCritical) + Case EM_INVALID_SOURCE_ID: Call MsgBox(" ", vbExclamation) + Case EM_INVALID_PATH: Call MsgBox(Fmt(" z: {1}", unwrapped), vbExclamation) + Case EM_INVALID_LINK: Call MsgBox(Fmt(" , {1}", unwrapped), vbExclamation) + Case EM_VALIDATION_FAIL: Call MsgBox(" ", vbExclamation) + + Case IM_IMPORT_COMPLETE: Call MsgBox(Fmt(" " & vbNewLine & " : {1}", unwrapped), vbInformation) + Case IM_CLEAR_ALL: 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 As Long: answer = vbNo + Select Case theCode + ' Case QM_ADD_TITLELINK + ' answer = MsgBox("! " & vbNewLine & _ + ' " ID: " & p1 & vbNewLine & _ + ' " . ?", vbYesNo + vbQuestion) + + 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..525bf2e --- /dev/null +++ b/src/database/z_UIRibbon.bas @@ -0,0 +1,11 @@ +Attribute VB_Name = "z_UIRibbon" +' +Option Explicit + +Sub OnRibbonBtn(control As IRibbonControl) + Select Case control.ID + Case "ImportWord": Call RunImportWord + Case "FollowLink": Call RunFollowLink + Case "ClearAll": Call RunClearAll + End Select +End Sub diff --git a/src/test/s_WordInteractions.cls b/src/test/s_WordInteractions.cls new file mode 100644 index 0000000..1efc728 --- /dev/null +++ b/src/test/s_WordInteractions.cls @@ -0,0 +1,56 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_WordInteractions" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public Function Setup() + Call SetupTestAddin +End Function + +Public Function Teardown() + Call TeardownTestAddin + Call ClearAll +End Function + +Public Function t_ImportInvalid() + On Error GoTo PROPAGATE_ERROR + + Dim iParams As New ExtractionOptions + iParams.detector_ = T_DETECTOR_DATE + + Call Dev_NewCase("No file") + Call Dev_ExpectEQ(ProcessImports("invalid.txt", False, iParams, bSilent:=True), 0) + Call Dev_ExpectEQ(SourceSheet.Cells(2, 1), "") + + Call Dev_NewCase("Invalid detector") + iParams.detector_ = T_DETECTOR_UNKNOWN + Call Dev_ExpectEQ(ProcessImports(GetTestFile, False, iParams, bSilent:=True), 0) + + Call Dev_NewCase("Invalid parameter") + iParams.detector_ = T_DETECTOR_LIST + iParams.param_ = "invalid.txt" + Call Dev_ExpectEQ(ProcessImports(GetTestFile, False, iParams, bSilent:=True), 0) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ImportDates() + On Error GoTo PROPAGATE_ERROR + + Dim iParams As New ExtractionOptions + iParams.detector_ = T_DETECTOR_DATE + Call Dev_ExpectEQ(ProcessImports(GetTestFile, False, iParams, bSilent:=True), 4) + Call Dev_ExpectNE(SourceSheet.Cells(2, 1), "") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/test/TestBasic.docx b/test/TestBasic.docx new file mode 100644 index 0000000..e082c93 Binary files /dev/null and b/test/TestBasic.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..84a8a54 --- /dev/null +++ b/ui/addin/customUI.xml @@ -0,0 +1,108 @@ + + + + + + + + + + +