Initial commit

This commit is contained in:
IRBorisov 2024-06-07 19:54:55 +03:00
commit bffee727b5
26 changed files with 1704 additions and 0 deletions

33
VBAMake.txt Normal file
View File

@ -0,0 +1,33 @@
# == Properties Section ==
# configuration properties
# use .ini format to define properties
# mandatory properties: name, artifact_home, source_home
id = BatchAI
name = BatchAI
description = Пакетная обработка файлов
artifact_home = BatchAI
source_home = BatchAI
install_home = \\fs1.concept.ru\projects\10 Автоматизация деятельности\02 Офисная автоматизация\00 Обработчики
%%
# === Build section ===
# Available commands:
# build LOCAL_MANIFEST
# copy LOCAL_SOURCE -> [LOCAL_ARTIFACT]
# save_as LOCAL_ARTIFACT -> LOCAL_ARTIFACT
# run LOCAL_SOURCE.bat
copy distr\Шаблоны -> Шаблоны
build script\MainProcessor.txt
%%
# === Install section ==
# Available commands:
# install LOCAL_ARTIFACT -> [INSTALL_PATH]
# add_template LOCAL_ARTIFACT -> [LOCAL_TEMPLATE]
# run LOCAL_ARTIFACT.bat <- [PARAMETERS]
# run APPLICATION <- [PARAMETERS]
install Шаблоны
install !Пакетная обработка.xlsm

1
VERSION Normal file
View File

@ -0,0 +1 @@
1.3.0

Binary file not shown.

100
script/MainProcessor.txt Normal file
View File

@ -0,0 +1,100 @@
# == Properties Section ==
# configuration properties
# use .ini format to define properties
# mandatory properties: name, artifact
name = !Пакетная обработка.xlsm
artifact = !Пакетная обработка.xlsm
%%
# === Imports Section ===
# Hierarchy of folders and files
# Use Tabulator to mark next level in hierarchy
# All folders are nested into SharedHome path
dev
DevTester.bas
api
ex_WinAPI.bas
ex_Python.bas
API_Python.cls
API_UserInteraction.cls
API_XLWrapper.cls
API_VsoWrapper.cls
API_WordWrapper.cls
utility
ex_VBA.bas
ex_Regex.bas
ex_DataPreparation.bas
API_Config.cls
API_JSON.cls
API_Timer.cls
excel
ex_Excel.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
processor
DataAccess.bas
DevHelper.bas
Declarations.bas
Main.bas
MainImpl.bas
z_UIMessages.bas
z_UIRibbon.bas
OptionsSubstitutes.cls
AProcessor.cls
ProcessorSubstitute.cls
ProcessorOrders.cls
ProcessorSaveAs.cls
ProcessorMasterDoc.cls
ProcessorFormatMine.cls
DB_Substitutes.cls
DB_Sources.cls
IteratorSource.cls
IteratorSubstitute.cls
test
s_DBSources.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
processor\.rels -> _rels\.rels
processor\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 : MSForms
global : Scripting
global : Visio
global : Word
global : VBScript_RegExp_55
global : Shell32
global : ADODB

Binary file not shown.

View File

@ -0,0 +1,12 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "AProcessor"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Public Function ProcessSource(iSource As IteratorSource): End Function

View File

@ -0,0 +1,109 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "DB_Sources"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private data_ As Excel.Worksheet
Public Function Init(target As Excel.Worksheet)
Set data_ = target
End Function
Public Property Get Data() As Excel.Worksheet
Set Data = data_
End Property
Public Property Get TargetFolder() As String
TargetFolder = ThisWorkbook.Names(CELL_FOLDER).RefersToRange
End Property
Public Property Get FileMask() As String
FileMask = ThisWorkbook.Names(CELL_MASK).RefersToRange
End Property
Public Property Let TargetFolder(newVal$)
ThisWorkbook.Names(CELL_FOLDER).RefersToRange = newVal
End Property
Public Property Let FileMask(newVal$)
ThisWorkbook.Names(CELL_MASK).RefersToRange = newVal
End Property
Public Function IBegin() As IteratorSource
Set IBegin = New IteratorSource
Call IBegin.Init(data_)
End Function
Public Function ILast() As IteratorSource
Set ILast = New IteratorSource
Call ILast.Init(data_)
Call ILast.GoLast
End Function
Public Function Count() As Long
Count = ILast.row_ - IBegin.row_ + 1
End Function
Public Function INew() As IteratorSource
Set INew = New IteratorSource
Call INew.Init(data_)
Call INew.GoLast
Call INew.Increment
End Function
Public Function Clear()
Call data_.UsedRange.Offset(1).ClearContents
End Function
Public Function ClearCounters()
Dim sHeader$: sHeader = data_.Cells(1, S_SRC_COUNTER)
Call data_.Columns.Item(S_SRC_COUNTER).ClearContents
data_.Cells(1, S_SRC_COUNTER) = sHeader
End Function
Public Function LoadSourcesFrom(sFolder$, sMask$) As Long
Dim iFiles As Collection: Set iFiles = ListFilesIn(sFolder, sMask)
LoadSourcesFrom = iFiles.Count
Dim nID&: nID = Application.WorksheetFunction.Max(data_.Columns(S_SRC_ID)) + 1
Dim iOut As IteratorSource: Set iOut = INew
Dim sFile As Variant
Dim fso As New Scripting.FileSystemObject
For Each sFile In iFiles
iOut.SourceID = nID
iOut.FileName = fso.GetFileName(CStr(sFile))
iOut.Extension = fso.GetExtensionName(CStr(sFile))
iOut.Path = sFile
nID = nID + 1
Call iOut.Increment
Next sFile
End Function
Public Function AcceptProcessor(iProcessor As AProcessor, Optional bShowProgress As Boolean = False)
If bShowProgress Then
Call CSE_ProgressBar.Init("Îáðàáîòêà äîêóìåíòîâ", maxVal:=Count, canInterrupt:=True)
Call CSE_ProgressBar.ShowModeless
End If
Dim iter As IteratorSource: Set iter = IBegin
Do While Not iter.IsDone
If bShowProgress Then
If CSE_ProgressBar.Interrupted Then _
Exit Do
CSE_ProgressBar.Description = iter.FileName
End If
Call iProcessor.ProcessSource(iter)
Call iter.Increment
If bShowProgress Then _
Call CSE_ProgressBar.IncrementA
Loop
If bShowProgress Then _
Call Unload(CSE_ProgressBar)
End Function

View File

@ -0,0 +1,62 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "DB_Substitutes"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private data_ As Excel.Worksheet
Public Function Init(target As Excel.Worksheet)
Set data_ = target
End Function
Public Function IBegin() As IteratorSubstitute
Set IBegin = New IteratorSubstitute
Call IBegin.Init(data_)
End Function
Public Function ILast() As IteratorSubstitute
Set ILast = New IteratorSubstitute
Call ILast.Init(data_)
Call ILast.GoLast
End Function
Public Function INew() As IteratorSubstitute
Set INew = New IteratorSubstitute
Call INew.Init(data_)
Call INew.GoLast
Call INew.Increment
End Function
Public Function Count() As Long
Count = ILast.row_ - IBegin.row_ + 1
End Function
Public Function Clear()
Call data_.UsedRange.Offset(1).ClearContents
End Function
Public Function ClearCounters()
Dim sHeader$: sHeader = data_.Cells(1, S_MATCH_COUNTER)
Call data_.Columns.Item(S_MATCH_COUNTER).ClearContents
data_.Cells(1, S_MATCH_COUNTER) = sHeader
End Function
Public Function Processor() As ProcessorSubstitute
Dim opts As New OptionsSubstitutes
With opts
.caseSensitive_ = ThisWorkbook.Names(CELL_MATCHCASE).RefersToRange
.wholeWord_ = ThisWorkbook.Names(CELL_WHOLEWORD).RefersToRange
.regex_ = ThisWorkbook.Names(CELL_REGEX).RefersToRange
.mark_ = ThisWorkbook.Names(CELL_MARK_REPLACED).RefersToRange
End With
Dim iProcessor As New ProcessorSubstitute
Call iProcessor.Init(opts, Me)
Set Processor = iProcessor
End Function

View File

@ -0,0 +1,25 @@
Attribute VB_Name = "DataAccess"
Option Private Module
Option Explicit
Public Function AccesSubstitutes() As DB_Substitutes
Static s_Substitutes As DB_Substitutes
If s_Substitutes Is Nothing Then
Set s_Substitutes = New DB_Substitutes
Call s_Substitutes.Init(ThisWorkbook.Worksheets(SHEET_SUBSTITUTES))
End If
Set AccesSubstitutes = s_Substitutes
End Function
Public Function AccessSources() As DB_Sources
Static s_Sources As DB_Sources
If s_Sources Is Nothing Then
Set s_Sources = New DB_Sources
Call s_Sources.Init(ThisWorkbook.Worksheets(SHEET_SOURCES))
End If
Set AccessSources = s_Sources
End Function

View File

@ -0,0 +1,67 @@
Attribute VB_Name = "Declarations"
Option Explicit
Public Const FIRST_ROW = 2
Public Const SHEET_SOURCES = "Ôàéëû"
Public Const SHEET_SUBSTITUTES = "Ïîäñòàíîâêè"
Public Const SHEET_ORDERS = "Ïîëíîìî÷èÿ"
Public Const SHEET_EXCEPTIONS = "Èñêëþ÷åíèÿ"
Public Const SHEET_COMMENTS = "Êîììåíòàðèè"
Public Const CELL_FOLDER = "c_Folder"
Public Const CELL_MASK = "c_Mask"
Public Const CELL_MATCHCASE = "c_MatchCase"
Public Const CELL_WHOLEWORD = "c_WholeWord"
Public Const CELL_REGEX = "c_Regex"
Public Const CELL_MARK_REPLACED = "c_Mark"
Public Const CELL_DELETE_SOURCE = "c_DeleteSource"
Public Const CELL_FILES = "c_FilesCount"
Public Const TEMPLATES_PATH = "\\fs1.concept.ru\projects\10 Àâòîìàòèçàöèÿ äåÿòåëüíîñòè\02 Îôèñíàÿ àâòîìàòèçàöèÿ\00 Îáðàáîò÷èêè\Øàáëîíû"
Public Const TEMPLATE_ORDERS = "Ïîëíîìî÷èÿ.xltx"
Public Enum SourcesStruct
[_First] = 1
S_SRC_ID = 1
S_SRC_NAME = 2
S_SRC_EXTENSION = 3
S_SRC_PATH = 4
S_SRC_COUNTER = 5
[_Last] = 5
End Enum
Public Enum MatchesStruct
[_First] = 1
S_MATCH_TARGET = 1
S_MATCH_REPLACEMENT = 2
S_MATCH_MORPHO = 3
S_MATCH_COUNTER = 4
[_Last] = 4
End Enum
Public Enum OutputStruct
S_OUT_ID = 1
S_OUT_SRC = 2
S_OUT_PREFIX = 3
S_OUT_TEXT = 4
S_OUT_END = 5
End Enum
Public Enum CommentStruct
S_COM_ID = 1
S_COM_SRC = 2
S_COM_TEXT = 3
End Enum
Public Enum MiningFormat
MINE_UNDERLINE = 1
MINE_HIGHLIGHT = 2
End Enum

View File

@ -0,0 +1,36 @@
Attribute VB_Name = "DevHelper"
Option Private Module
Option Explicit
Public Const TEST_TARGET_FOLDER = "testFiles"
Public Function Dev_PrepareSkeleton()
' Do nothing
End Function
Public Function Dev_ManualRunTest()
Dim sSuite$: sSuite = "s_DBSources"
Dim sTest$: sTest = "t_Clear"
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_DBSources": Set Dev_GetTestSuite = New s_DBSources
End Select
End Function
Public Function TestFilesFolder() As String
Dim fso As New Scripting.FileSystemObject
TestFilesFolder = fso.GetParentFolderName(ThisWorkbook.Path) & "\" & TEST_TARGET_FOLDER
End Function
Public Function SetupTestFolder() As String
Dim fso As New Scripting.FileSystemObject
Dim sFolder$: sFolder = fso.GetParentFolderName(ThisWorkbook.Path) & "\" & TEST_TARGET_FOLDER
If Not fso.FolderExists(sFolder) Then _
Call fso.CreateFolder(sFolder)
SetupTestFolder = sFolder
End Function

View File

@ -0,0 +1,86 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "IteratorSource"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Public row_ As Long
Private data_ As Excel.Worksheet
Public Sub Init(target As Excel.Worksheet, Optional tRow& = FIRST_ROW)
Set data_ = target
row_ = tRow
End Sub
Public Function Increment(Optional inc& = 1)
If row_ + inc > 0 Then _
row_ = row_ + inc
End Function
Public Function IncrementCounter(Optional inc& = 1)
Counter = Counter + inc
End Function
Public Function GoFirst()
row_ = FIRST_ROW
End Function
Public Function GoLast()
row_ = data_.Columns(S_SRC_ID).Find(vbNullString, LookAt:=xlWhole).Row - 1
End Function
Public Function IsDone() As Boolean
IsDone = data_.Cells(row_, S_SRC_ID) = vbNullString
End Function
Public Function RemoveRow()
Call data_.Rows(row_).Delete
End Function
'===== Propertiy Get =====
Public Property Get SourceID() As Long
SourceID = data_.Cells(row_, S_SRC_ID)
End Property
Public Property Get FileName() As String
FileName = data_.Cells(row_, S_SRC_NAME)
End Property
Public Property Get Extension() As String
Extension = data_.Cells(row_, S_SRC_EXTENSION)
End Property
Public Property Get Path() As String
Path = data_.Cells(row_, S_SRC_PATH)
End Property
Public Property Get Counter() As Long
Counter = data_.Cells(row_, S_SRC_COUNTER)
End Property
' ==== Property Let ====
Public Property Let SourceID(newVal&)
data_.Cells(row_, S_SRC_ID) = newVal
End Property
Public Property Let FileName(newVal$)
data_.Cells(row_, S_SRC_NAME) = newVal
End Property
Public Property Let Extension(newVal$)
data_.Cells(row_, S_SRC_EXTENSION) = newVal
End Property
Public Property Let Path(newVal$)
data_.Cells(row_, S_SRC_PATH) = newVal
Call XLUpdateHyperlink(data_.Cells(row_, S_SRC_PATH), newVal)
End Property
Public Property Let Counter(newVal&)
data_.Cells(row_, S_SRC_COUNTER) = newVal
End Property

View File

@ -0,0 +1,87 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "IteratorSubstitute"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Public row_ As Long
Private data_ As Excel.Worksheet
Public Sub Init(target As Excel.Worksheet, Optional tRow& = FIRST_ROW)
Set data_ = target
row_ = tRow
End Sub
Public Function Increment(Optional inc& = 1)
If row_ + inc > 0 Then _
row_ = row_ + inc
End Function
Public Function IncrementCounter()
Counter = Counter + 1
End Function
Public Function GoFirst()
row_ = FIRST_ROW
End Function
Public Function GoLast()
row_ = data_.Columns(S_MATCH_TARGET).Find(vbNullString, LookAt:=xlWhole).Row - 1
End Function
Public Function IsDone() As Boolean
IsDone = data_.Cells(row_, S_MATCH_TARGET) = vbNullString
End Function
Public Function RemoveRow()
Call data_.Rows(row_).Delete
End Function
'===== Propertiy Get =====
Public Property Get FindWhat() As String
FindWhat = data_.Cells(row_, S_MATCH_TARGET)
End Property
Public Property Get Replacement() As String
Replacement = data_.Cells(row_, S_MATCH_REPLACEMENT)
End Property
Public Property Get UseMorpho() As Boolean
UseMorpho = data_.Cells(row_, S_MATCH_MORPHO) <> 0
End Property
Public Property Get Counter() As Long
Counter = data_.Cells(row_, S_MATCH_COUNTER)
End Property
Public Property Get IsMultipleWords() As Boolean
IsMultipleWords = True
Dim sData$: sData = FindWhat
Dim nChar&
For nChar = 1 To VBA.Len(sData)
Dim sChar$: sChar = VBA.Mid(sData, nChar, 1)
If Not IsAlphaNumeric(sChar) Then _
Exit Function
Next nChar
IsMultipleWords = False
End Property
' ==== Property Let ====
Public Property Let FindWhat(newVal$)
data_.Cells(row_, S_MATCH_TARGET) = newVal
End Property
Public Property Let Replacement(newVal$)
data_.Cells(row_, S_MATCH_REPLACEMENT) = newVal
End Property
Public Property Let Counter(newVal&)
data_.Cells(row_, S_MATCH_COUNTER) = newVal
End Property

162
src/processor/Main.bas Normal file
View File

@ -0,0 +1,162 @@
Attribute VB_Name = "Main"
Option Explicit
Public Sub RunAddSources()
Dim iData As DB_Sources: Set iData = AccessSources
If Not PromptFolderMask(iData) Then _
Exit Sub
Dim xlUI As New API_XLWrapper: Call xlUI.SetDocument(ThisWorkbook)
Call xlUI.PauseUI
Dim nCount&: nCount = iData.LoadSourcesFrom(iData.TargetFolder, iData.FileMask)
Call xlUI.ResumeUI
Call iData.Data.Activate
Call UserInteraction.ShowMessage(IM_FILES_UPDATED, nCount)
End Sub
Public Sub RunNewSources()
Dim iData As DB_Sources: Set iData = AccessSources
If Not PromptFolderMask(iData) Then _
Exit Sub
Dim xlUI As New API_XLWrapper: Call xlUI.SetDocument(ThisWorkbook)
Call xlUI.PauseUI
Call iData.Clear
Dim nCount&: nCount = iData.LoadSourcesFrom(iData.TargetFolder, iData.FileMask)
Call xlUI.ResumeUI
Call iData.Data.Activate
Call UserInteraction.ShowMessage(IM_FILES_UPDATED, nCount)
End Sub
Public Sub RunClearSources()
Call AccessSources.Clear
Call UserInteraction.ShowMessage(IM_FILES_CLEARED)
End Sub
Public Sub RunConvertToDocx()
Dim iData As DB_Sources: Set iData = AccessSources
Dim iProcessor As New ProcessorSaveAs: Call iProcessor.Init("docx", bDeleteSource:=True)
Call iData.ClearCounters
Call iData.AcceptProcessor(iProcessor, bShowProgress:=True)
Call iProcessor.Finalize
Call UserInteraction.ShowMessage(IM_CONVERT_EXTENSION, iProcessor.countProcessed_, iProcessor.countAll_)
End Sub
Public Sub RunMasterDocument()
Dim iData As DB_Sources: Set iData = AccessSources
Dim iProcessor As New ProcessorMasterDoc: Call iProcessor.Init
Call iData.ClearCounters
Call iData.AcceptProcessor(iProcessor, bShowProgress:=True)
Call iProcessor.Finalize
Call iProcessor.word_.Document.ActiveWindow.Activate
Call UserInteraction.ShowMessage(IM_MASTERDOC, iProcessor.countProcessed_, iProcessor.countAll_)
End Sub
Public Sub RunSaveAs()
Dim sExtension$: sExtension = UserInteraction.PromptInput("Ââåäèòå öåëåâîå ðàñøèðåíèå", "Âûáîð ðàñøèðåíèÿ", sInitial:="pdf")
If sExtension = vbNullString Then _
Exit Sub
Dim bDeleteSource As Boolean: bDeleteSource = ThisWorkbook.Names(CELL_DELETE_SOURCE).RefersToRange = 1
Dim iData As DB_Sources: Set iData = AccessSources
Dim iProcessor As New ProcessorSaveAs: Call iProcessor.Init(sExtension, bDeleteSource)
Call iData.AcceptProcessor(iProcessor, bShowProgress:=True)
Call iProcessor.Finalize
Call UserInteraction.ShowMessage(IM_CONVERT_EXTENSION, iProcessor.countProcessed_, iProcessor.countAll_)
End Sub
Public Sub RunMarkSubstitutes()
Dim iData As DB_Sources: Set iData = AccessSources
Dim iSubstitutes As DB_Substitutes: Set iSubstitutes = AccesSubstitutes
Dim iProcessor As ProcessorSubstitute: Set iProcessor = iSubstitutes.Processor
iProcessor.GetOptions.doReplace_ = False
iProcessor.GetOptions.mark_ = True
Call iData.ClearCounters
Call iSubstitutes.ClearCounters
Call iData.AcceptProcessor(iProcessor, bShowProgress:=True)
Call iProcessor.Finalize
Call UserInteraction.ShowMessage(IM_SUBSTITUTES_MARKED)
End Sub
Public Sub RunExecuteSubstitutes()
Call AccessPython.StartServer
If Not AccessPython.Validate Then _
Call UserInteraction.ShowMessage(EM_NO_PYTHON)
Dim iData As DB_Sources: Set iData = AccessSources
Dim iSubstitutes As DB_Substitutes: Set iSubstitutes = AccesSubstitutes
Dim iProcessor As ProcessorSubstitute: Set iProcessor = iSubstitutes.Processor
iProcessor.GetOptions.doReplace_ = True
Call iData.ClearCounters
Call iSubstitutes.ClearCounters
Call iData.AcceptProcessor(iProcessor, bShowProgress:=True)
Call iProcessor.Finalize
Call UserInteraction.ShowMessage(IM_SUBSTITUTES_DONE)
End Sub
Public Sub RunMineOrders()
Dim iOutput As Excel.Workbook: Set iOutput = PrepareOrdersOutput()
If iOutput Is Nothing Then _
Exit Sub
Dim iData As DB_Sources: Set iData = AccessSources
Dim iProcessor As New ProcessorOrders: Call iProcessor.Init(iOutput)
Dim theTimer As New API_Timer: Call theTimer.Start
Dim xlUI As New API_XLWrapper: Call xlUI.SetDocument(iOutput)
Call xlUI.PauseUI
Call iData.AcceptProcessor(iProcessor)
Call xlUI.ResumeUI
Call iProcessor.Finalize
Call iOutput.Activate
Call UserInteraction.ShowMessage(IM_ORDERS_PROCESSED, theTimer.TimeStr)
End Sub
Public Sub RunExtractUnderlined()
Dim iOutput As Excel.Workbook: Set iOutput = PrepareFormatOutput()
If iOutput Is Nothing Then _
Exit Sub
Dim iData As DB_Sources: Set iData = AccessSources
Dim iProcessor As New ProcessorFormatMine: Call iProcessor.Init(iOutput.Sheets(1), MINE_UNDERLINE)
Dim theTimer As New API_Timer: Call theTimer.Start
Dim xlUI As New API_XLWrapper: Call xlUI.SetDocument(iOutput)
Call xlUI.PauseUI
Call iData.AcceptProcessor(iProcessor)
Call xlUI.ResumeUI
Call iProcessor.Finalize
Call iOutput.Activate
Call UserInteraction.ShowMessage(IM_EXTRACT_SUCCESS, theTimer.TimeStr)
End Sub
Public Sub RunExtractColored()
Dim iOutput As Excel.Workbook: Set iOutput = PrepareFormatOutput()
If iOutput Is Nothing Then _
Exit Sub
Dim iData As DB_Sources: Set iData = AccessSources
Dim iProcessor As New ProcessorFormatMine: Call iProcessor.Init(iOutput.Sheets(1), MINE_HIGHLIGHT)
Dim theTimer As New API_Timer: Call theTimer.Start
Dim xlUI As New API_XLWrapper: Call xlUI.SetDocument(iOutput)
Call xlUI.PauseUI
Call iData.AcceptProcessor(iProcessor)
Call xlUI.ResumeUI
Call iProcessor.Finalize
Call iOutput.Activate
Call UserInteraction.ShowMessage(IM_EXTRACT_SUCCESS, theTimer.TimeStr)
End Sub

View File

@ -0,0 +1,36 @@
Attribute VB_Name = "MainImpl"
Option Private Module
Option Explicit
Public Function ClearAll()
Call AccessSources.Clear
Call AccesSubstitutes.Clear
End Function
Public Function PromptFolderMask(iData As DB_Sources) As Boolean
PromptFolderMask = False
Dim sMask$: sMask = UserInteraction.PromptInput("Ââåäèòå ìàñêó ôàéëó", "Ìàñêà èìåíè", sInitial:=iData.FileMask)
If sMask = vbNullString Then _
Exit Function
Dim sFolder$: sFolder = UserInteraction.PromptFolder(iData.TargetFolder & "\")
If sFolder = vbNullString Then _
Exit Function
iData.TargetFolder = sFolder
iData.FileMask = sMask
PromptFolderMask = True
End Function
Public Function PrepareOrdersOutput() As Excel.Workbook
Dim iExcel As New API_XLWrapper: Call iExcel.SetApplication(ThisWorkbook.Application)
Set PrepareOrdersOutput = iExcel.NewDocument(sTemplate:=TEMPLATES_PATH & "\" & TEMPLATE_ORDERS, bDefaultIfFail:=False)
End Function
Public Function PrepareFormatOutput() As Excel.Workbook
Dim iExcel As New API_XLWrapper: Call iExcel.SetApplication(ThisWorkbook.Application)
Set PrepareFormatOutput = iExcel.NewDocument()
iExcel.Document.Sheets(1).Cells(1, 1) = "File"
iExcel.Document.Sheets(1).Cells(1, 2) = "Data"
End Function

View File

@ -0,0 +1,16 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "OptionsSubstitutes"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Public caseSensitive_ As Boolean
Public wholeWord_ As Boolean
Public regex_ As Boolean
Public mark_ As Boolean
Public doReplace_ As Boolean

View File

@ -0,0 +1,82 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ProcessorFormatMine"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Implements AProcessor
Private word_ As API_WordWrapper
Private doc_ As Word.Document
Private out_ As Excel.Worksheet
Private row_ As Long
Private format_ As MiningFormat
Public Function Init(iOut As Excel.Worksheet, iFormat As MiningFormat)
Set word_ = New API_WordWrapper: Call word_.CreateApplication
Set out_ = iOut
row_ = FIRST_ROW
format_ = iFormat
End Function
Public Function Finalize()
Call word_.ReleaseApplication
End Function
Public Function AProcessor_ProcessSource(iSource As IteratorSource)
If ApplicationFromExtension(iSource.Extension) <> T_APP_WORD Then _
Exit Function
Set doc_ = word_.OpenDocument(iSource.Path, bReadOnly:=True)
If doc_ Is Nothing Then _
Exit Function
Dim iData As Collection: Set iData = FindAllIn(doc_.Range)
Dim sText As Variant
For Each sText In iData
out_.Cells(row_, 1) = iSource.Path
out_.Cells(row_, 2) = CStr(sText)
row_ = row_ + 1
Next sText
Call word_.ReleaseDocument(bCloseApplication:=False)
End Function
' ======
Private Function FindAllIn(target As Word.Range) As Collection
Dim iFound As Collection: Set iFound = New Collection
Call SetupFindParams(target)
Do While target.Find.Execute
Call iFound.Add(TrimWhitespace(target.Text))
Call target.Collapse(wdCollapseEnd)
Loop
Set FindAllIn = iFound
End Function
Private Function SetupFindParams(target As Word.Range)
Call target.Find.ClearFormatting
Select Case format_
Case MiningFormat.MINE_HIGHLIGHT
With target.Find
.Text = ""
.Format = True
.Highlight = True
End With
Case MiningFormat.MINE_UNDERLINE
With target.Find
.Text = ""
.Format = True
.Font.Underline = wdUnderlineSingle
End With
End Select
End Function

View File

@ -0,0 +1,44 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ProcessorMasterDoc"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Implements AProcessor
Public word_ As API_WordWrapper
Public countProcessed_ As Long
Public countAll_ As Long
Public Function Init()
countProcessed_ = 0
countAll_ = 0
Set word_ = New API_WordWrapper: Call word_.CreateApplication
Call word_.NewDocument
word_.Document.ActiveWindow.ActivePane.View.Type = wdOutlineView
word_.Document.ActiveWindow.View = wdMasterView
End Function
Public Function Finalize()
End Function
Public Function AProcessor_ProcessSource(iSource As IteratorSource)
countAll_ = countAll_ + 1
On Error GoTo FAILED_TO_ADD
Call word_.Document.Subdocuments.AddFromFile(iSource.Path, ConfirmConversions:=True, ReadOnly:=False, Revert:=False)
On Error GoTo 0
countProcessed_ = countProcessed_ + 1
Exit Function
FAILED_TO_ADD:
End Function

View File

@ -0,0 +1,213 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ProcessorOrders"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Implements AProcessor
Private word_ As API_WordWrapper
Private doc_ As Word.Document
Private sourceOut_ As IteratorSource
Private orders_ As Excel.Worksheet
Private exceptions_ As Excel.Worksheet
Private comments_ As Excel.Worksheet
Private rowOrder_ As Long
Private rowException_ As Long
Private rowComment_ As Long
Public countOrders_ As Long
Public countExceptions_ As Long
Public countComments_ As Long
Public Function Init(iOut As Excel.Workbook)
Set word_ = New API_WordWrapper: Call word_.CreateApplication
Set orders_ = iOut.Sheets(SHEET_ORDERS)
Set exceptions_ = iOut.Sheets(SHEET_EXCEPTIONS)
Set comments_ = iOut.Sheets(SHEET_COMMENTS)
Set sourceOut_ = New IteratorSource: Call sourceOut_.Init(iOut.Sheets(SHEET_SOURCES))
countOrders_ = 0
countExceptions_ = 0
countComments_ = 0
rowOrder_ = FIRST_ROW
rowException_ = FIRST_ROW
rowComment_ = FIRST_ROW
End Function
Public Function Finalize()
Call word_.ReleaseApplication
End Function
Public Function AProcessor_ProcessSource(iSource As IteratorSource)
If ApplicationFromExtension(iSource.Extension) <> T_APP_WORD Then _
Exit Function
Set doc_ = word_.OpenDocument(iSource.Path, bReadOnly:=True)
If doc_ Is Nothing Then _
Exit Function
Dim iOrdersRange As Word.Range: Set iOrdersRange = FindOrders()
If iOrdersRange Is Nothing Then _
Exit Function
Dim nSource&: nSource = iSource.SourceID
Dim nCount&: nCount = 0
Dim aPar As Word.Paragraph
For Each aPar In iOrdersRange.Paragraphs
Dim target As Word.Range: Set target = aPar.Range
Dim sText$: sText = SubstituteWhitespace(target.Text)
If IsComment(target) Then
Call AddComment(nSource, sText)
ElseIf IsValidOrder(sText) Then
Call ProcessOrder(sText, nSource)
nCount = nCount + 1
Else
Call ProcessException(sText, nSource)
End If
Next aPar
Call word_.ReleaseDocument(bCloseApplication:=False)
Call OutputSource(iSource, nCount)
End Function
' ====
Private Function FindOrders() As Word.Range
Dim iFind As Word.Range: Set iFind = doc_.Range
With iFind.Find
.Style = doc_.Styles(wdStyleHeading1)
.Wrap = wdFindStop
End With
Dim nStart&: nStart = 0
Do While iFind.Find.Execute
If iFind.Text Like "*[Ïï]îëíîìî÷èÿ*" Then
nStart = iFind.End
Call iFind.Collapse(wdCollapseEnd)
Exit Do
End If
Call iFind.Collapse(wdCollapseEnd)
Loop
If nStart = 0 Then _
Exit Function
If Not iFind.Find.Execute Then _
Exit Function
Dim nEnd&: nEnd = iFind.Start
iFind.Start = nStart
iFind.End = nEnd
Set FindOrders = iFind
End Function
Private Function IsComment(target As Word.Range) As Boolean
IsComment = True
Dim sStyle$: sStyle = target.Style
If sStyle Like "*[Êê]îììåíòàðèé*" Then _
Exit Function
If sStyle Like "*[Èè]íôîðìàöèÿ î*" Then _
Exit Function
IsComment = False
End Function
Private Function IsValidOrder(sText$) As Boolean
IsValidOrder = False
If sText Like "*[Óó]òðàòèë ñèëó*" Then _
Exit Function
If sText Like "*[Óó]òðàòèëè ñèëó*" Then _
Exit Function
If sText Like "*[Èè]ñêëþ÷[å¸]í[.;:]" Then _
Exit Function
If sText Like "*[Èè]ñêëþ÷[å¸]íû[.;:]" Then _
Exit Function
IsValidOrder = True
End Function
Private Function ProcessOrder(sText$, nSource&) As Boolean
Dim sPrefix$: sPrefix = ExtractPrefix(sText)
If sPrefix <> vbNullString Then _
sText = VBA.Trim(VBA.Right(sText, VBA.Len(sText) - VBA.Len(sPrefix) - 1))
Dim bIsFinish As Boolean: bIsFinish = Not sText Like "*:"
Call AddOrder(nSource, sPrefix, sText, bIsFinish)
End Function
Private Function ProcessException(sText$, nSource&)
Dim sPrefix$: sPrefix = ExtractPrefix(sText)
If sPrefix <> vbNullString Then _
sText = VBA.Trim(VBA.Right(sText, VBA.Len(sText) - VBA.Len(sPrefix) - 1))
Dim bIsFinish As Boolean: bIsFinish = Not sText Like "*:"
Call AddException(nSource, sPrefix, sText, bIsFinish)
End Function
Private Function ExtractPrefix(sText$) As String
Dim nPrefix&: nPrefix = 0
Do While VBA.Mid(sText, nPrefix + 1, 1) Like "[ ().0123456789-]"
nPrefix = nPrefix + 1
Loop
If nPrefix = 0 Then _
Exit Function
ExtractPrefix = VBA.Trim(VBA.Left(sText, nPrefix))
End Function
Private Function AddOrder(nSrc&, sPrefix$, sText$, bIsFinish As Boolean)
countOrders_ = countOrders_ + 1
orders_.Cells(rowOrder_, S_OUT_ID) = countOrders_
orders_.Cells(rowOrder_, S_OUT_SRC) = nSrc
orders_.Cells(rowOrder_, S_OUT_PREFIX) = sPrefix
orders_.Cells(rowOrder_, S_OUT_TEXT) = sText
orders_.Cells(rowOrder_, S_OUT_END) = IIf(bIsFinish, 1, 0)
rowOrder_ = rowOrder_ + 1
End Function
Private Function AddException(nSrc&, sPrefix$, sText$, bIsFinish As Boolean)
countExceptions_ = countExceptions_ + 1
exceptions_.Cells(rowException_, S_OUT_ID) = countExceptions_
exceptions_.Cells(rowException_, S_OUT_SRC) = nSrc
exceptions_.Cells(rowException_, S_OUT_PREFIX) = sPrefix
exceptions_.Cells(rowException_, S_OUT_TEXT) = sText
exceptions_.Cells(rowException_, S_OUT_END) = IIf(bIsFinish, 1, 0)
rowException_ = rowException_ + 1
End Function
Private Function AddComment(nSrc&, sText$)
countComments_ = countComments_ + 1
comments_.Cells(rowComment_, S_COM_ID) = countComments_
comments_.Cells(rowComment_, S_COM_SRC) = nSrc
comments_.Cells(rowComment_, S_COM_TEXT) = sText
rowComment_ = rowComment_ + 1
End Function
Private Function OutputSource(iSource As IteratorSource, nCount&)
With sourceOut_
.Counter = nCount
.FileName = iSource.FileName
.Extension = iSource.Extension
.Path = iSource.Path
.SourceID = iSource.SourceID
Call .Increment
End With
End Function

View File

@ -0,0 +1,106 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ProcessorSaveAs"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Implements AProcessor
Private targetExtension_ As String
Private deleteSource_ As Boolean
Private fso_ As Scripting.FileSystemObject
Private word_ As API_WordWrapper
Private xl_ As API_XLWrapper
Private vso_ As API_VsoWrapper
Public countProcessed_ As Long
Public countAll_ As Long
Public Function Init(sExtension$, bDeleteSource As Boolean)
Set fso_ = New Scripting.FileSystemObject
countProcessed_ = 0
countAll_ = 0
targetExtension_ = sExtension
deleteSource_ = bDeleteSource
End Function
Public Function Finalize()
If Not word_ Is Nothing Then _
Call word_.ReleaseApplication
If Not xl_ Is Nothing Then _
Call xl_.ReleaseApplication
If Not vso_ Is Nothing Then _
Call vso_.ReleaseApplication
End Function
Public Function AProcessor_ProcessSource(iSource As IteratorSource)
Dim sExt$: sExt = VBA.UCase(iSource.Extension)
If sExt = VBA.UCase(targetExtension_) Then
countAll_ = countAll_ + 1
iSource.Counter = 0
Exit Function
End If
Dim iWrapper As Object: Set iWrapper = GetWrapper(ApplicationFromExtension(sExt))
If iWrapper Is Nothing Then _
Exit Function
countAll_ = countAll_ + 1
iSource.Counter = -1
Dim sOldPath$: sOldPath = iSource.Path
If iWrapper.OpenDocument(sOldPath, bReadOnly:=False) Is Nothing Then _
Exit Function
Dim sNewPath$: sNewPath = fso_.GetParentFolderName(sOldPath) & "\" & fso_.GetBaseName(sOldPath) & "." & targetExtension_
If fso_.FileExists(sNewPath) Then _
GoTo SAFE_EXIT
If Not iWrapper.SaveAs(sNewPath) Then _
GoTo SAFE_EXIT
countProcessed_ = countProcessed_ + 1
iSource.Counter = 1
iSource.FileName = fso_.GetFileName(sNewPath)
iSource.Extension = "docx"
iSource.Path = sNewPath
Call word_.ReleaseDocument(bCloseApplication:=False)
If deleteSource_ Then _
Call fso_.DeleteFile(sOldPath)
Exit Function
SAFE_EXIT:
Call word_.ReleaseDocument(bCloseApplication:=False)
End Function
' ======
Private Function GetWrapper(nAppl As TApplication) As Object
Select Case nAppl
Case T_APP_WORD
If word_ Is Nothing Then
Set word_ = New API_WordWrapper
Call word_.CreateApplication
End If
Set GetWrapper = word_
Case T_APP_EXCEL
If xl_ Is Nothing Then
Set xl_ = New API_XLWrapper
Call xl_.CreateApplication
End If
Set GetWrapper = xl_
Case T_APP_VISIO
If vso_ Is Nothing Then
Set vso_ = New API_VsoWrapper
Call vso_.CreateApplication
End If
Set GetWrapper = vso_
End Select
End Function

View File

@ -0,0 +1,219 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ProcessorSubstitute"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Implements AProcessor
Private substitutes_ As DB_Substitutes
Private options_ As OptionsSubstitutes
Private word_ As API_WordWrapper
Private visio_ As API_VsoWrapper
Private hasPython_ As Boolean
Public Function Init(iOptions As OptionsSubstitutes, iSubstitutes As DB_Substitutes)
Set options_ = iOptions
Set substitutes_ = iSubstitutes
hasPython_ = AccessPython.Validate
End Function
Public Function Finalize()
If Not word_ Is Nothing Then _
Call word_.ReleaseApplication
If Not visio_ Is Nothing Then _
Call visio_.ReleaseApplication
End Function
Public Function GetOptions() As OptionsSubstitutes
Set GetOptions = options_
End Function
Public Function AProcessor_ProcessSource(iSource As IteratorSource)
Dim iAppl As TApplication: iAppl = ApplicationFromExtension(iSource.Extension)
If iAppl = T_APP_VISIO Then
Call ProcessVisio(iSource)
ElseIf iAppl = T_APP_WORD Then
Call ProcessWord(iSource)
End If
End Function
' ======
Private Function AccessWord() As API_WordWrapper
If word_ Is Nothing Then
Set word_ = New API_WordWrapper
Call word_.CreateApplication
End If
Set AccessWord = word_
End Function
Private Function AccessVisio() As API_VsoWrapper
If visio_ Is Nothing Then
Set visio_ = New API_VsoWrapper
Call visio_.CreateApplication
End If
Set AccessVisio = visio_
End Function
Private Function ProcessVisio(iSource As IteratorSource)
Dim iDoc As Visio.Document: Set iDoc = AccessVisio.OpenDocument(iSource.Path)
If iDoc Is Nothing Then _
Exit Function
Dim iShape As Visio.Shape
Dim iPage As Visio.Page
For Each iPage In iDoc.Pages
For Each iShape In iPage.Shapes
If iShape.Type = visTypeShape Then _
Call iSource.IncrementCounter(ProcessShapeText(iShape))
Next iShape
Next iPage
Call AccessVisio.ReleaseDocument(bCloseApplication:=False, bSaveChanges:=True)
End Function
Private Function ProcessShapeText(target As Visio.Shape) As Long
Dim shpText$: shpText = VBA.Trim(target.Text)
If shpText = vbNullString Then _
Exit Function
Dim iter As IteratorSubstitute: Set iter = substitutes_.IBegin
Do While Not iter.IsDone
Dim sNeedle$: sNeedle = iter.FindWhat
If Not RegexTest(shpText, sNeedle) Then _
GoTo NEXT_TEST
ProcessShapeText = ProcessShapeText + 1
Call iter.IncrementCounter
If options_.doReplace_ Then _
target.Text = RegexReplace(shpText, sNeedle, iter.Replacement, 1)
If options_.mark_ Then _
target.Characters.CharProps(visCharacterStyle) = visItalic
NEXT_TEST:
Call iter.Increment
Loop
End Function
Private Function ProcessWord(iSource As IteratorSource)
Dim iDoc As Word.Document: Set iDoc = AccessWord.OpenDocument(iSource.Path, bReadOnly:=False)
If iDoc Is Nothing Then _
Exit Function
If CSE_ProgressBar.Visible Then _
Call CSE_ProgressBar.InitSecondBar(maxVal:=substitutes_.Count)
Dim bNeedSpaces As Boolean
Dim iter As IteratorSubstitute: Set iter = substitutes_.IBegin
Do While Not iter.IsDone
Dim rFind As Word.Range: Set rFind = iDoc.Range
bNeedSpaces = iter.IsMultipleWords And options_.wholeWord_
If CSE_ProgressBar.Visible Then _
If CSE_ProgressBar.Interrupted Then _
Exit Do
With rFind.Find
.Text = IIf(bNeedSpaces, PrepareSearchText(iter.FindWhat), iter.FindWhat)
.MatchCase = options_.caseSensitive_
.MatchWholeWord = options_.wholeWord_
.MatchWildcards = options_.regex_ Or bNeedSpaces
End With
Do While rFind.Find.Execute
If bNeedSpaces Then
rFind.Start = rFind.Start + 1
rFind.End = rFind.End - 1
End If
If options_.doReplace_ Then _
Call ReplaceTextInRange(rFind, iter.Replacement, iter.UseMorpho)
Call iSource.IncrementCounter
Call iter.IncrementCounter
If options_.mark_ Then _
rFind.HighlightColorIndex = IIf(options_.doReplace_, wdGray25, wdGray50)
Call rFind.Collapse(wdCollapseEnd)
Loop
If CSE_ProgressBar.Visible Then _
Call CSE_ProgressBar.IncrementB
Call iter.Increment
Loop
If CSE_ProgressBar.Visible Then _
Call CSE_ProgressBar.HideSecondBar
Call AccessWord.ReleaseDocument(bCloseApplication:=False, bSaveChanges:=True)
End Function
Private Function PrepareSearchText(sQuery$) As String
Dim sFirstSymbol$: sFirstSymbol = VBA.Left$(sQuery, 1)
If sFirstSymbol <> "[" Then
PrepareSearchText = "[" & VBA.UCase(sFirstSymbol) & VBA.LCase(sFirstSymbol) & "]" & VBA.Right(sQuery, VBA.Len(sQuery) - 1)
Else
PrepareSearchText = sQuery
End If
PrepareSearchText = "[ ^0013^0009\-]" & PrepareSearchText & "[ ^0013^0009.,\!\?\-\)]"
End Function
Private Function ReplaceTextInRange(target As Word.Range, sReplacement$, bMorpho As Boolean)
If bMorpho And hasPython_ Then
Dim sNextWord$, sPrevWord$
If target.Next(wdCharacter, 1) = " " Then
Dim nextWordRange As Word.Range: Set nextWordRange = target.Duplicate
Call nextWordRange.Collapse(wdCollapseEnd)
Set nextWordRange = nextWordRange.Next(wdWord, 1)
sNextWord = VBA.Trim(nextWordRange.Text)
If Not IsAlphaNumeric(sNextWord) Then sNextWord = ""
End If
If target.Previous(wdCharacter, 1) = " " Then
Dim prevWordRange As Word.Range: Set prevWordRange = target.Duplicate
Call prevWordRange.Collapse(wdCollapseStart)
Set prevWordRange = prevWordRange.Previous(wdWord, 1)
sPrevWord = VBA.Trim(prevWordRange.Text)
If Not IsAlphaNumeric(sPrevWord) Then sPrevWord = ""
End If
sReplacement = ApplyMorpho(sReplacement, sPrevWord, sNextWord)
End If
Dim sFirstSymbol$: sFirstSymbol = VBA.Left$(target.Text, 1)
If sFirstSymbol Like "[À-ßA-Z]" Then
target.Text = CapitalizeFirstLetter(sReplacement)
Else
target.Text = sReplacement
End If
End Function
Private Function ApplyMorpho(sTarget$, sPrev$, sNext$) As String
Dim sInflected$: sInflected = AccessPython.CallFunction(PY_MODULE_TEXT, "inflect_context", Array(sTarget, sPrev, sNext))
If sInflected = "" Or sInflected Like "*error*" Then _
sInflected = sTarget
ApplyMorpho = sInflected
End Function
Private Function ExtractAdjectiveForm(sParse$) As String
Dim sResult$
If VBA.InStr(1, sParse, "plur") <> 0 Then
sResult = "plur"
Else
If VBA.InStr(1, sParse, "femn") <> 0 Then
sResult = "femn,sing"
ElseIf VBA.InStr(1, sParse, "masc") <> 0 Then
sResult = "masc,sing"
Else
sResult = "neut,sing"
End If
End If
sResult = sResult & "," & VBA.Right(sParse, VBA.Len(sParse) - VBA.InStrRev(sParse, ","))
ExtractAdjectiveForm = sResult
End Function

View File

@ -0,0 +1,67 @@
Attribute VB_Name = "z_UIMessages"
' Messaging module
Option Private Module
Option Explicit
Public Enum MsgCode
MSG_OK = 0
IM_FILES_CLEARED
IM_FILES_UPDATED
IM_SUBSTITUTES_MARKED
IM_SUBSTITUTES_DONE
IM_ORDERS_PROCESSED
IM_CONVERT_EXTENSION
IM_MASTERDOC
IM_EXTRACT_SUCCESS
EM_NO_PYTHON
' QM_CODE_DELETE_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 UIShowMessage(theCode As MsgCode, ParamArray params() As Variant)
Dim unwrapped As Variant: unwrapped = params
unwrapped = FixForwardedParams(unwrapped)
Select Case theCode
Case IM_FILES_CLEARED: Call MsgBox("Ñïèñîê ôàéëîâ î÷èùåí", vbInformation)
Case IM_FILES_UPDATED: Call MsgBox(Fmt("Ñïèñîê îáíîâëåí: {1} ôàéëîâ", unwrapped), vbInformation)
Case IM_SUBSTITUTES_MARKED: Call MsgBox("Ðàçìåòêà ïðîèçâåäåíà", vbInformation)
Case IM_SUBSTITUTES_DONE: Call MsgBox("Çàìåíû ïðîèçâåäåíû", vbInformation)
Case IM_ORDERS_PROCESSED: Call MsgBox(Fmt("Îáðàáîòêà ïîëíîìî÷èé çàâåðøåíà çà {1}", unwrapped), vbInformation)
Case IM_CONVERT_EXTENSION: Call MsgBox(Fmt("Ôàéëû ïåðåñîõðàíåíû: {1}/{2}", unwrapped), vbInformation)
Case IM_MASTERDOC: Call MsgBox(Fmt("Ìàñòåð äîêóìåíò ñîçäàí: {1}/{2}", unwrapped), vbInformation)
Case IM_EXTRACT_SUCCESS: Call MsgBox(Fmt("Âûãðóçêà äàííûõ çàâåðøåíà çà {1}", unwrapped), vbInformation)
Case EM_NO_PYTHON: Call MsgBox("Ìîðôîëîãè÷åñêèé ìîäóëü íå äîñòóïåí. Çàìåíû áóäóò ïðîèçâîäèòüñÿ áåç ó÷åòà ñëîâîôîðì", vbExclamation)
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_CODE_DELETE_CONFIRM
' answer = MsgBox("Are you sure you want to delete ALL macros from target file?", vbYesNo + vbQuestion)
Case Else: Call MsgBox("Invalid message code", vbCritical)
End Select
UIAskQuestion = answer = vbYes
End Function

View File

@ -0,0 +1,23 @@
Attribute VB_Name = "z_UIRibbon"
Option Explicit
Option Private Module
Public Sub OnRibbonBtn(iControl As IRibbonControl)
Select Case iControl.ID
Case "AddSources": Call RunAddSources
Case "NewSources": Call RunNewSources
Case "ClearSources": Call RunClearSources
Case "ConvertToDocx": Call RunConvertToDocx
Case "MasterDocument": Call RunMasterDocument
Case "SaveAs": Call RunSaveAs
Case "MarkSubstitutes": Call RunMarkSubstitutes
Case "ExecuteSubstitutes": Call RunExecuteSubstitutes
Case "MineOrders": Call RunMineOrders
Case "ExtractUnderlined": Call RunExtractUnderlined
Case "ExtractColored": Call RunExtractColored
End Select
End Sub

53
src/test/s_DBSources.cls Normal file
View File

@ -0,0 +1,53 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "s_DBSources"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
' TODO:
' Public Function LoadSourcesFrom(sFolder$, sMask$) As Long
Private db_ As DB_Sources
Private fso_ As Scripting.FileSystemObject
Private folder_ As String
Public Function Setup()
' Mandatory setup function
Set db_ = AccessSources
Set fso_ = New Scripting.FileSystemObject
folder_ = SetupTestFolder
End Function
Public Function Teardown()
' Mandatory teardown function
Call db_.Clear
Call fso_.DeleteFolder(TestFilesFolder)
End Function
Public Function t_Clear()
On Error GoTo PROPAGATE_ERROR
Dim iter As IteratorSource: Set iter = db_.INew
iter.Counter = 1
iter.FileName = "test.txt"
Call Dev_ExpectEQ(1, iter.Counter)
Call Dev_ExpectEQ("test.txt", iter.FileName)
Call Dev_NewCase("ClearCounters")
Call db_.ClearCounters
Call Dev_ExpectEQ(0, iter.Counter)
Call Dev_ExpectEQ("test.txt", iter.FileName)
Call Dev_NewCase("ClearAll")
Call db_.Clear
Call Dev_ExpectEQ("", iter.FileName)
Exit Function
PROPAGATE_ERROR:
Call Dev_LogError(Err.Number, Err.Description)
End Function

2
ui/processor/.rels Normal file
View File

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

63
ui/processor/customUI.xml Normal file
View File

@ -0,0 +1,63 @@
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
<ribbon>
<tabs>
<tab id="BatchAI" label="Пакетная обработка" >
<group id="Actions" label="Действия" >
<menu id="SourceListMenu" label="Файлы" imageMso="GroupAllFilesManage" size="large">
<button id="AddSources" label="Добавить"
supertip="Добавить файлы из указанного каталога к обрабатываемым"
imageMso="MoreSearchCriteria"
onAction="OnRibbonBtn"/>
<button id="NewSources" label="Заменить"
supertip="Заменить обрабатываемые файлы на файлы из указанного каталога"
imageMso="MeetingsToolAppointmentRecurrence"
onAction="OnRibbonBtn"/>
<button id="ClearSources" label="Очистить"
supertip="Очистить список обрабатываемых файлов"
imageMso="ChangeToDeclineInvitation"
onAction="OnRibbonBtn"/>
<button id="ConvertToDocx" label="doc/rtf -> docx"
supertip="Конвертировать текстовые документы в docx"
imageMso="FileSaveAsWordDocx"
onAction="OnRibbonBtn"/>
<button id="MasterDocument" label="Мастер документ"
supertip="Создать Мастер документ, добавив в него документы по ссылкам"
imageMso="EditMaster"
onAction="OnRibbonBtn"/>
<button id="SaveAs" label="Изменить расширение"
supertip="Сохранить файлы под другим расширением"
imageMso="FileSaveAs"
onAction="OnRibbonBtn"/>
</menu>
<menu id="SubstituteListMenu" label="Замены" imageMso="FontsReplaceFonts" size="large">
<button id="MarkSubstitutes" label="Отметить"
supertip="Отметить подстановки (не выполняя)"
imageMso="FormatPainter"
onAction="OnRibbonBtn"/>
<button id="ExecuteSubstitutes" label="Выполнить"
supertip="Провести набор подстановок"
imageMso="AnimationStartDropdown"
onAction="OnRibbonBtn"/>
</menu>
<menu id="MiningListMenu" label="Mining" imageMso="JotFindHitResults" size="large">
<button id="MineOrders" label="Полномочия"
supertip="Извлечь полномочия из отобранных файлов (только Word)"
imageMso="SmartArtConvedrtToText"
onAction="OnRibbonBtn"/>
<button id="ExtractUnderlined" label="Подчеркнутые"
supertip="Извлечь подчеркнутый текст"
imageMso="UnderlineWords"
onAction="OnRibbonBtn"/>
<button id="ExtractColored" label="Выделенные"
supertip="Извлечь выделенный цветом текст"
imageMso="TextHighlightColorPicker"
onAction="OnRibbonBtn"/>
</menu>
</group>
</tab>
</tabs>
</ribbon>
</customUI>