Initial commit

.gitignore

@@ -0,0 +1,2 @@
+~*
+

api/API_Path.cls

@@ -0,0 +1,183 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_Path"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ================ Ðàáîòà ñ ïóòÿìè ê ôàéëàì =============
+' Shared module version: 20221031
+' Tested in: TestCommons
+' Depends on: ex_VBA
+' Required reference: Scripting
+Option Explicit
+
+Private Enum PathType
+  T_PATH_INVALID = 0
+
+  T_PATH_GLOBAL = 1
+  T_PATH_LOCAL = 2
+  T_PATH_ENVIRON = 3
+End Enum
+
+Private data_ As String
+Private type_ As PathType
+
+Public Function FromString(sText$) As API_Path
+  data_ = sText
+  type_ = InternalEvaluate(data_)
+  Set FromString = Me
+End Function
+
+Public Function Clone() As API_Path
+  Set Clone = New API_Path
+  Call Clone.FromString(data_)
+End Function
+
+Public Property Get Text() As String
+  Text = data_
+End Property
+
+Public Property Get ParentFolder() As String
+  Dim fso As New Scripting.FileSystemObject
+  ParentFolder = fso.GetParentFolderName(data_)
+End Property
+
+Public Property Get FileName() As String
+  Dim fso As New Scripting.FileSystemObject
+  FileName = fso.GetFileName(data_)
+End Property
+
+Public Property Get BaseName() As String
+  Dim fso As New Scripting.FileSystemObject
+  BaseName = fso.GetBaseName(data_)
+End Property
+
+Public Property Get Extension() As String
+  Dim fso As New Scripting.FileSystemObject
+  Extension = fso.GetExtensionName(data_)
+End Property
+
+Public Function ToGlobal(sHome$) As API_Path
+  Select Case type_
+    Case T_PATH_LOCAL: data_ = ConvertLocal(data_, sHome)
+    Case T_PATH_ENVIRON: data_ = ConvertEnviron(data_)
+    Case T_PATH_INVALID, T_PATH_GLOBAL:
+  End Select
+  type_ = InternalEvaluate(data_)
+  Set ToGlobal = Me
+End Function
+
+Public Function ToLocal(sHome$) As API_Path
+  Set ToLocal = Me
+  Dim nPrefix&: nPrefix = CommonPrefixLength(data_, sHome, vbTextCompare)
+  If nPrefix = 0 Then _
+    Exit Function
+  
+  If VBA.Mid(data_, nPrefix, 1) = "\" Then
+    nPrefix = nPrefix - 1
+  ElseIf VBA.Mid(data_, nPrefix + 1, 1) <> "\" Then
+    nPrefix = VBA.InStrRev(data_, "\", nPrefix)
+    If nPrefix < 3 Then _
+      Exit Function
+  End If
+  
+  Dim fso As New Scripting.FileSystemObject
+  Dim sFolder$: sFolder = sHome
+  Dim sPrefix$
+  Do While VBA.Len(sFolder) > nPrefix
+    sFolder = fso.GetParentFolderName(sFolder)
+    sPrefix = sPrefix & "..\"
+  Loop
+  
+  data_ = VBA.Right(data_, VBA.Len(data_) - nPrefix - 1)
+  If sPrefix <> vbNullString Then _
+    data_ = sPrefix & data_
+  type_ = InternalEvaluate(data_)
+End Function
+
+Public Function ToServer(sHome$) As API_Path
+  Call ToGlobal(sHome)
+  data_ = SubstituteServer(data_)
+  type_ = InternalEvaluate(data_)
+  Set ToServer = Me
+End Function
+
+Public Function GlobalToServer() As API_Path
+  data_ = SubstituteServer(data_)
+  type_ = InternalEvaluate(data_)
+  Set GlobalToServer = Me
+End Function
+
+Public Function LocalExists(sHome$) As Boolean
+  Dim sFile$
+  If type_ = T_PATH_LOCAL Then
+    sFile = ConvertLocal(data_, sHome)
+  Else
+    sFile = data_
+  End If
+  LocalExists = CheckPath(sFile)
+End Function
+
+Public Function GlobalExists() As Boolean
+  GlobalExists = CheckPath(data_)
+End Function
+
+' ========
+Private Function InternalEvaluate(sPath$) As PathType
+  If VBA.Len(sPath) < 3 Then
+    InternalEvaluate = T_PATH_INVALID
+  ElseIf VBA.Mid(sPath, 2, 1) = ":" Or VBA.Left(sPath, 2) = "\\" Then
+    InternalEvaluate = T_PATH_GLOBAL
+  ElseIf sPath Like "%*%*" Then
+    InternalEvaluate = T_PATH_ENVIRON
+  Else
+    InternalEvaluate = T_PATH_LOCAL
+  End If
+End Function
+
+Private Function SubstituteServer(sPath$) As String
+  If VBA.Len(sPath) < 3 Then
+    SubstituteServer = sPath
+  ElseIf VBA.Left(sPath, 3) = "P:\" Then
+    SubstituteServer = "\\fs1.concept.ru\projects\" & VBA.Right(sPath, VBA.Len(sPath) - 3)
+  ElseIf VBA.Left(sPath, 3) = "X:\" Then
+    SubstituteServer = "\\fs1.concept.ru\Exchange\" & VBA.Right(sPath, VBA.Len(sPath) - 3)
+  Else
+    SubstituteServer = sPath
+  End If
+End Function
+
+Private Function ConvertLocal(sPath$, sHome$) As String
+  Dim nEllipsis&: nEllipsis = VBA.InStrRev(sPath, "..\")
+  If nEllipsis = 0 Then
+    ConvertLocal = sHome & "\" & sPath
+  Else
+    Dim fso As New Scripting.FileSystemObject
+    Dim nCount&: nCount = 1 + nEllipsis / 3
+    Dim sFolder$: sFolder = sHome
+    Do While nCount > 0
+      sFolder = fso.GetParentFolderName(sFolder)
+      nCount = nCount - 1
+    Loop
+    ConvertLocal = sFolder & "\" & VBA.Right(sPath, VBA.Len(sPath) - nEllipsis - 2)
+  End If
+End Function
+
+Private Function ConvertEnviron(sPath$) As String
+  Dim nHeader&: nHeader = VBA.InStr(2, sPath, "%")
+  Dim sVariable$: sVariable = VBA.Mid(sPath, 2, nHeader - 2)
+  ConvertEnviron = VBA.Environ$(sVariable) & "\" & VBA.Right(sPath, VBA.Len(sPath) - nHeader - 1)
+End Function
+
+Private Function CheckPath(sPath$) As Boolean
+  Dim fso As New Scripting.FileSystemObject
+  CheckPath = True
+  If fso.FileExists(sPath) Then _
+    Exit Function
+  If fso.FolderExists(sPath) Then _
+    Exit Function
+  CheckPath = False
+End Function

api/API_Project.cls

@@ -0,0 +1,235 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_Project"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ================ Import / export code functionality =============
+' Shared module version: 20220407
+' Tested in:
+' Depends on:
+' Required reference: Scripting, VBIDE
+Option Explicit
+
+Private fso_ As Scripting.FileSystemObject
+Private proj_ As VBIDE.VBProject
+
+Private contents_ As Scripting.Dictionary
+Private sharedContents_ As Scripting.Dictionary
+
+Private sourceHome_ As String
+Private importsHome_ As String
+
+Private Sub Class_Initialize()
+  Set fso_ = New Scripting.FileSystemObject
+End Sub
+
+Private Sub Class_Terminate()
+  Call Detach
+End Sub
+
+Public Function Init(target As VBIDE.VBProject, Optional sImportsHome$ = "") As Boolean
+  Init = target.Protection <> 1
+  If Not Init Then
+    Call MsgBox("Project code is protected, cannot acccess", vbCritical)
+    Exit Function
+  End If
+  
+  Set proj_ = target
+  importsHome_ = sImportsHome
+  
+  Set contents_ = New Scripting.Dictionary
+  Set sharedContents_ = New Scripting.Dictionary
+End Function
+
+Public Function Detach()
+  Set proj_ = Nothing
+  importsHome_ = ""
+End Function
+
+Public Function SetInternals(ByRef oContents As Scripting.Dictionary, _
+                            ByRef oSharedCont As Scripting.Dictionary)
+  Set contents_ = oContents
+  Set sharedContents_ = oSharedCont
+End Function
+
+Public Function ExportSrcTo(sPath$)
+  sourceHome_ = sPath
+  Call PrepareFolders(contents_)
+  Call InternalExport(contents_)
+End Function
+
+Public Function ExportShared()
+  sourceHome_ = importsHome_
+  Call PrepareFolders(sharedContents_)
+  Call InternalExport(sharedContents_)
+End Function
+
+Public Function ImportSrcFrom(sPath$)
+  sourceHome_ = sPath
+  Call InternalImport(contents_)
+End Function
+
+Public Function ImportShared()
+  sourceHome_ = importsHome_
+  Call InternalImport(sharedContents_)
+End Function
+
+Public Function RemoveAll()
+  Dim nItem&: nItem = 1
+  Dim aComponent As VBIDE.VBComponent
+  Do While nItem <= proj_.VBComponents.Count
+    Set aComponent = proj_.VBComponents.Item(nItem)
+    If aComponent.Type <> vbext_ct_Document Then
+      If Not TryRemoving(aComponent) Then _
+        nItem = nItem + 1
+    Else
+      nItem = nItem + 1
+    End If
+  Loop
+End Function
+
+Public Function AddItem(sName$, sFolder$)
+  Call contents_.Add(sName, sFolder)
+End Function
+
+Public Function AddSharedItem(sName$, sFolder$)
+  Call sharedContents_.Add(sName, sFolder)
+End Function
+
+Public Function ReloadFrom(sFile$) As Boolean
+  ReloadFrom = False
+  If fso_.FileExists(sFile) Then _
+    ReloadFrom = TryImportFile(fso_.GetFile(sFile))
+End Function
+
+' =========
+Private Function PrepareFolders(target As Scripting.Dictionary)
+  Call ProjEnsureFolderExists(sourceHome_)
+  
+  Dim sKey As Variant
+  For Each sKey In target
+    Call ProjEnsureFolderExists(sourceHome_ & "\" & CStr(target(sKey)))
+  Next sKey
+End Function
+
+Private Function InternalExport(target As Scripting.Dictionary)
+  Dim fso As New Scripting.FileSystemObject
+  Dim aComponent As VBComponent
+  For Each aComponent In proj_.VBComponents
+    Dim sName$: sName = ComponentName(aComponent)
+    If Not target.Exists(sName) Then _
+      GoTo NEXT_COMPONENT
+    
+    Dim sPath$: sPath = sourceHome_ & "\" & target(sName) & "\" & sName
+    If aComponent.Type = vbext_ct_MSForm Then _
+      If HasNoChanges(aComponent, sPath) Then _
+        GoTo NEXT_COMPONENT
+    Call aComponent.Export(sPath)
+NEXT_COMPONENT:
+  Next aComponent
+End Function
+
+Private Function InternalImport(tContents As Scripting.Dictionary)
+  Dim sFileName As Variant
+  Dim sPath$
+  For Each sFileName In tContents
+    sPath = sourceHome_ & "\" & tContents(sFileName) & "\" & CStr(sFileName)
+    If fso_.FileExists(sPath) Then _
+      Call TryImportFile(fso_.GetFile(sPath))
+  Next sFileName
+End Function
+
+Private Function TryImportFile(target As Scripting.File) As Boolean
+  TryImportFile = False
+  
+  Dim sExt$: sExt = fso_.GetExtensionName(target.Name)
+  Dim sName$: sName = fso_.GetBaseName(target.Name)
+  Dim sComp As VBIDE.VBComponent: Set sComp = ComponentByName(sName)
+  If Not sComp Is Nothing Then _
+    If Not TryRemoving(sComp) Then _
+      Exit Function
+      
+  Call proj_.VBComponents.Import(target.Path)
+  If sExt = "frm" Then _
+    Call RemoveEmptyFirstLine(ComponentByName(sName).CodeModule)
+  
+  TryImportFile = True
+End Function
+
+Private Function ComponentName(target As VBComponent) As String
+  ComponentName = target.Name
+  Select Case target.Type
+    Case vbext_ct_ClassModule: ComponentName = ComponentName & ".cls"
+    Case vbext_ct_MSForm: ComponentName = ComponentName & ".frm"
+    Case vbext_ct_StdModule: ComponentName = ComponentName & ".bas"
+    Case Else: ComponentName = vbNullString
+  End Select
+End Function
+
+Private Function RemoveEmptyFirstLine(target As CodeModule)
+  Dim firstLineTxt$: firstLineTxt = target.Lines(1, 1)
+  If firstLineTxt = vbNullString Then _
+    Call target.DeleteLines(1, 1)
+End Function
+
+Private Function TryRemoving(target As VBIDE.VBComponent) As Boolean
+  Dim nCount&
+  nCount = proj_.VBComponents.Count
+  Call proj_.VBComponents.Remove(target)
+  TryRemoving = nCount <> proj_.VBComponents.Count
+End Function
+
+Private Function ComponentByName(sName$) As VBIDE.VBComponent
+  Dim aComponent As VBComponent
+  For Each aComponent In proj_.VBComponents
+    If aComponent.Name = sName Then
+      Set ComponentByName = aComponent
+      Exit Function
+    End If
+  Next aComponent
+End Function
+
+Private Function ProjEnsureFolderExists(sPath$)
+  If fso_.FolderExists(sPath) Then _
+    Exit Function
+  
+  Dim sParent$: sParent = sPath
+  Do While VBA.Right(sParent, 1) = "\"
+    sParent = VBA.Left(sParent, VBA.Len(sParent) - 1)
+  Loop
+  sParent = VBA.Left(sParent, VBA.InStrRev(sParent, "\") - 1)
+  
+  Call ProjEnsureFolderExists(sParent)
+  Call fso_.CreateFolder(sPath)
+End Function
+
+Private Function HasNoChanges(aForm As VBIDE.VBComponent, sPath$) As Boolean
+  HasNoChanges = False
+  
+  Dim fso As New Scripting.FileSystemObject
+  If Not fso.FileExists(sPath) Then _
+    Exit Function
+    
+  Dim tmpDir$: tmpDir = fso.GetParentFolderName(sPath) & "\tmpFrm"
+  Dim tmpFile$: tmpFile = tmpDir & "\" & aForm.Name & ".frm"
+  Call fso.CreateFolder(tmpDir)
+  Call aForm.Export(tmpFile)
+  
+  Dim nFile1&: nFile1 = FreeFile
+  Open sPath For Input As #nFile1
+  Dim cont1 As Variant: cont1 = Input(LOF(nFile1), nFile1)
+  Close nFile1
+  
+  Dim nFile2&: nFile2 = FreeFile
+  Open tmpFile For Input As #nFile2
+  Dim cont2 As Variant: cont2 = Input(LOF(nFile2), nFile2)
+  Close nFile2
+  
+  HasNoChanges = cont1 = cont2
+  Call fso.DeleteFolder(tmpDir)
+End Function
+

api/API_Python.cls

@@ -0,0 +1,221 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_Python"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+'================ Python process object =========================
+' Shared module version: 20220713
+' Tested in: PythonManager
+' Depends on:
+' Required reference:
+Option Explicit
+
+Private Const CONCEPT_DLL_LOCATION = "C:\Tools\dll"
+
+#If Win64 Then
+  Private Const PY_DLL_NAME As String = "vbatopy-connector64.dll"
+  
+  Private Declare PtrSafe Function StartPythonServer Lib "vbatopy-connector64.dll" ( _
+    ByRef vResult As Variant, _
+    ByVal sPython As String, _
+    ByVal sModules As String, _
+    ByVal bShowConsole As Long) As Long
+    
+  Private Declare PtrSafe Function KillPythonServer Lib "vbatopy-connector64.dll" Alias "KillServer" () As Long
+  Private Declare PtrSafe Function GetServer Lib "vbatopy-connector64.dll" (ByRef vResult As Variant) As Long
+#Else
+  Private Const PY_DLL_NAME As String = "vbatopy-connector32.dll"
+  
+  Private Declare PtrSafe Function StartPythonServer Lib "vbatopy-connector32.dll" ( _
+    ByRef vResult As Variant, _
+    ByVal sPython As String, _
+    ByVal sModules As String, _
+    ByVal bShowConsole As Long) As Long
+    
+  Private Declare PtrSafe Function KillPythonServer Lib "vbatopy-connector32.dll" Alias "KillServer" () As Long
+  Private Declare PtrSafe Function GetServer Lib "vbatopy-connector32.dll" (ByRef vResult As Variant) As Long
+#End If
+
+Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal sLibrary As String) As Long
+Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal nLibraryHandle As Long) As Long
+
+Private python_ As Variant
+Private pythonPath_ As String
+Private modules_ As String
+Private showConsole_ As Boolean
+
+Private Sub Class_Initialize()
+  Call ClearCahce
+End Sub
+
+Private Sub Class_Terminate()
+  Call ClearCahce
+End Sub
+
+Public Function ClearCahce()
+  Set python_ = Nothing
+End Function
+
+' Initialize Python process
+' iPython - path to python / python command
+' sModules - path to python source code modules, delimiter = ';'
+' bDoDebug - flag to show console output for python process
+Public Function Init(iPython$, sModules$, Optional bDoDebug As Boolean = False)
+  Set python_ = Nothing
+  pythonPath_ = VBA.LCase(iPython)
+  pythonPath_ = VBA.Replace(pythonPath_, "program files (x86)", """program files (x86)""")
+  pythonPath_ = VBA.Replace(pythonPath_, "program files", """program files""")
+  pythonPath_ = VBA.Replace(pythonPath_, "\", "\\")
+  modules_ = sModules
+  showConsole_ = bDoDebug
+End Function
+
+' Validate server is running
+' If @python_ is not setup, then load current server dispatch into @python_
+Public Function Validate() As Boolean
+  Call LoadDLL
+  Call GetServer(python_)
+  Validate = Not python_ Is Nothing
+End Function
+
+Public Function StartServer()
+  Call Validate
+  If Not python_ Is Nothing Then _
+    Exit Function
+    
+  If StartPythonServer(python_, pythonPath_, modules_, IIf(showConsole_, 1, 0)) <> 0 Then _
+    Call RaiseServerError
+  
+  If VBA.VarType(python_) = vbString Then
+    Call RaiseServerError
+    Set python_ = Nothing
+  End If
+End Function
+
+Public Function KillServer()
+  Call Validate
+  If python_ Is Nothing Then _
+    Exit Function
+  If KillPythonServer() <> 0 Then _
+    Call RaiseServerError
+  Set python_ = Nothing
+End Function
+
+' Preload Python module before using it - use if long setup is needed to load module
+Public Function LoadModule(sFullPath$) As Boolean
+  On Error GoTo HANDLE_ERROR
+  LoadModule = Py.ImportModule(sFullPath) <> ""
+  On Error GoTo 0
+  Exit Function
+  
+HANDLE_ERROR:
+  Debug.Print Err.Description
+  LoadModule = False
+  On Error GoTo 0
+End Function
+
+' Run python command
+Public Function Execute(sPyCommand$) As Boolean
+  On Error GoTo HANDLE_ERROR
+  Call Py.Exec("" & sPyCommand & "")
+  On Error GoTo 0
+  Execute = True
+  Exit Function
+  
+HANDLE_ERROR:
+  Debug.Print Err.Description
+  Execute = False
+  On Error GoTo 0
+End Function
+
+' Evaluate python statement
+' Warning! Returns only basic types. Objects are not supported
+Public Function Evaluate(sPyStatement$) As Variant
+  On Error GoTo HANDLE_ERROR
+  Evaluate = Py.Eval("" & sPyStatement & "")
+  On Error GoTo 0
+  Exit Function
+  
+HANDLE_ERROR:
+  Debug.Print Err.Description
+  Evaluate = Err.Description
+  On Error GoTo 0
+End Function
+
+' Call function from module. Arguments will be available from python including COM wrappers for any Office objects
+' Warning! Returns basic types. To get objects from python use CallFunctionReturnObject
+Public Function CallFunction(sModule$, sFunc$, Optional vArgs As Variant) As Variant
+  On Error GoTo HANDLE_ERROR
+  If IsMissing(vArgs) Then
+    CallFunction = Py.CallFunction(sModule, sFunc)
+  Else
+    CallFunction = Py.CallFunction(sModule, sFunc, vArgs)
+  End If
+  On Error GoTo 0
+  Exit Function
+  
+HANDLE_ERROR:
+  Debug.Print Err.Description
+  CallFunction = Err.Description
+End Function
+
+Public Function CallFunctionReturnObject(sModule$, sFunc$, Optional vArgs As Variant) As Object
+  On Error GoTo HANDLE_ERROR
+  If IsMissing(vArgs) Then
+    Set CallFunctionReturnObject = Py.CallFunction(sModule, sFunc)
+  Else
+    Set CallFunctionReturnObject = Py.CallFunction(sModule, sFunc, vArgs)
+  End If
+  On Error GoTo 0
+  Exit Function
+  
+HANDLE_ERROR:
+  Debug.Print Err.Description
+  Set CallFunctionReturnObject = Nothing
+End Function
+
+' Create VBA wrapper for target Python module in destination file path
+Public Function WrapPython(sSourceModule$, sDestination$) As String
+  WrapPython = Py.WrapPython(sSourceModule, sDestination)
+End Function
+
+' Preload @vbatopy DLL
+' Note: Mostly usefull for testing setup because it allows using DLL calls without starting a server
+Public Function LoadDLL()
+  If LoadLibrary(PY_DLL_NAME) <> 0 Then _
+    Exit Function
+  If LoadLibrary(CONCEPT_DLL_LOCATION & "\" & PY_DLL_NAME) <> 0 Then _
+    Exit Function
+  ' TODO: remove fallback after some time
+  ' fallback path for earlier versions of distribution
+  If LoadLibrary(VBA.Environ("USERPROFILE") & "\.concept\dll\" & PY_DLL_NAME) = 0 Then _
+    Call Err.Raise(1, Description:="Could not load " & PY_DLL_NAME)
+End Function
+
+' Unload DLL - need to call this before replacing dll file
+Public Function UnloadDLL()
+  Dim nHandle&: nHandle = LoadLibrary(PY_DLL_NAME)
+  If nHandle <> 0 Then
+    Call KillServer
+    Call FreeLibrary(nHandle)
+  End If
+End Function
+
+' =========
+Private Property Get Py() As Variant
+  If python_ Is Nothing Then _
+    Call StartServer
+  Set Py = python_
+End Property
+
+Private Function RaiseServerError()
+  Dim sErr$: sErr = python_
+  Set python_ = Nothing
+  Debug.Print sErr
+  Call Err.Raise(1000, Description:=sErr)
+End Function
+

api/API_Ribbon.cls

@@ -0,0 +1,85 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_Ribbon"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+'==== Îáîëî÷êà äëÿ õðàíåíèÿ è çàãðóçêè èäåíòèôèêàòîðà ëåíòû (Ribbon) =========================
+' Shared module version: 20210217
+' Required reference: Microsoft Scripting Runtime
+Option Explicit
+
+Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, src As Any, ByVal nLen As Long)
+ 
+Private ribbon_ As IRibbonUI
+Private backup_ As String
+
+Private Sub Class_Terminate()
+  If Not ribbon_ Is Nothing Then _
+    Call KillBackup
+End Sub
+
+Public Function Init(target As IRibbonUI, sBackup$)
+  Set ribbon_ = target
+  backup_ = sBackup
+  Call SaveBackup
+End Function
+
+Public Property Get Value() As IRibbonUI
+  Set Value = ribbon_
+End Property
+
+Public Function LoadFrom(sFilePath$) As IRibbonUI
+  Set ribbon_ = Nothing
+  backup_ = sFilePath
+  
+  Call LoadBackup
+  
+  Set LoadFrom = ribbon_
+End Function
+
+' =======
+Private Function SaveBackup()
+  Dim ribbonPtr As LongPtr: ribbonPtr = ObjPtr(ribbon_)
+  Dim fso As New Scripting.FileSystemObject
+  Dim textOut As Scripting.TextStream: Set textOut = fso.CreateTextFile(backup_, Overwrite:=True)
+  If Not textOut Is Nothing Then
+    Call textOut.WriteLine(ribbonPtr)
+    Call textOut.Close
+  End If
+End Function
+
+Private Function LoadBackup()
+  Dim fso As New Scripting.FileSystemObject
+  If Not fso.FileExists(backup_) Then _
+    Exit Function
+  
+  Dim textIn As Scripting.TextStream: Set textIn = fso.OpenTextFile(backup_)
+  If textIn Is Nothing Then _
+    Exit Function
+  
+  Dim ptrSize&
+  #If Win64 Then
+    ptrSize = 8
+  #Else
+    ptrSize = 4
+  #End If
+  
+  Dim aLine$: aLine = textIn.ReadLine
+  If IsNumeric(aLine) Then
+    Dim nPtr As LongPtr: nPtr = CLngPtr(aLine)
+    Dim objRibbon As Object
+    Call CopyMemory(objRibbon, nPtr, ptrSize)
+    Set ribbon_ = objRibbon
+    Call CopyMemory(objRibbon, 0&, ptrSize)
+  End If
+End Function
+
+Private Function KillBackup()
+  Dim fso As New Scripting.FileSystemObject
+  If fso.FileExists(backup_) Then _
+    Call fso.DeleteFile(backup_)
+End Function

api/API_UserInteraction.cls

@@ -0,0 +1,121 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_UserInteraction"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+'================ Êëàññ èíêàïñóëÿöèè âçàèìîäåéñòâèÿ ñ ïîëüçîâàòåëåì =========================
+' Shared module version: 20220611
+' Depends on:
+' Required reference:
+Option Explicit
+
+Public Function ShowMessage(nMsg&, ParamArray params() As Variant)
+  Call UIShowMessage(nMsg, params)
+End Function
+
+Public Function AskQuestion(nQuestion&, ParamArray params() As Variant) As Boolean
+  AskQuestion = UIAskQuestion(nQuestion, params)
+End Function
+
+Public Function FollowHyperlink(oDocument As Object, sAddress$)
+  Call oDocument.FollowHyperlink(sAddress)
+End Function
+
+Public Function PromptInput(sPrompt$, Optional sTitle$ = vbNullString, Optional sInitial As Variant) As String
+  PromptInput = VBA.InputBox(sPrompt, sTitle, sInitial)
+End Function
+
+Public Function PromptFileFilter(sInitialPath$, sDescription$, sFilter$, _
+                                  Optional sTitle$ = "Âûáåðèòå ôàéë", _
+                                  Optional bNewApplication As Boolean = False) As String
+  Dim cFilters As New Collection
+  Dim cDescriptions As New Collection
+                      
+  Call cFilters.Add("*.*")
+  Call cDescriptions.Add("Âñå ôàéëû")
+  Call cFilters.Add(sFilter)
+  Call cDescriptions.Add(sDescription)
+  
+  PromptFileFilter = PromptFile(sInitialPath, sTitle, cDescriptions, cFilters, bNewApplication)
+End Function
+
+Public Function PromptFile(sInitialPath$, _
+                            Optional sTitle$ = "Âûáåðèòå ôàéë", _
+                            Optional cDescriptions As Collection = Nothing, _
+                            Optional cFilters As Collection = Nothing, _
+                            Optional bNewApplication As Boolean = False) As String
+  PromptFile = vbNullString
+  Dim oApplication As Object
+  If Not bNewApplication Then
+    Set oApplication = Application
+  Else
+    Set oApplication = CreateObject("Excel.Application")
+    oApplication.Visible = True
+  End If
+  
+  Dim filterCount&: filterCount = 0
+  If Not cDescriptions Is Nothing And Not cFilters Is Nothing Then _
+    If cDescriptions.Count = cFilters.Count Then _
+      filterCount = cFilters.Count
+  
+  On Error Resume Next
+  
+  With oApplication.FileDialog(msoFileDialogFilePicker)
+    .InitialFileName = sInitialPath
+    .AllowMultiSelect = False
+    .ButtonName = "Âûáðàòü"
+    .Title = sTitle
+    
+    Call .Filters.Clear
+    If filterCount > 0 Then
+      
+      Dim nItem&
+      For nItem = 1 To filterCount Step 1
+        Call .Filters.Add(cDescriptions.Item(nItem), cFilters.Item(nItem), 1)
+      Next nItem
+    Else
+      Call .Filters.Add("Âñå ôàéëû", "*.*")
+    End If
+    
+    Call .Show
+    If .SelectedItems.Count > 0 Then _
+      PromptFile = .SelectedItems(1)
+  End With
+  
+  If bNewApplication Then _
+    Call oApplication.Quit
+End Function
+
+Public Function PromptFolder(sInitialPath$, _
+                              Optional sTitle$ = "Âûáåðèòå êàòàëîã", _
+                              Optional bNewApplication As Boolean = False) As String
+  PromptFolder = vbNullString
+  Dim oApplication As Object
+  If Not bNewApplication Then
+    Set oApplication = Application
+  Else
+    Set oApplication = CreateObject("Excel.Application")
+    oApplication.Visible = True
+  End If
+  
+  On Error Resume Next
+  With oApplication.FileDialog(msoFileDialogFolderPicker)
+    .InitialFileName = sInitialPath
+    .AllowMultiSelect = False
+    .ButtonName = "Âûáðàòü"
+    .Title = sTitle
+    
+    Call .Show
+    
+    If .SelectedItems.Count > 0 Then _
+      PromptFolder = .SelectedItems(1)
+  End With
+  
+  If bNewApplication Then _
+    Call oApplication.Quit
+End Function
+

api/API_VsoWrapper.cls

@@ -0,0 +1,376 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_VsoWrapper"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ================ Êëàññ-îáîëî÷êà äëÿ äîêóìåíòà MS Visio =========================
+' Shared module version: 20220410
+' Tested in: TestCommons
+' Depends on:
+' Required reference: Scripting, Visio
+Option Explicit
+
+Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal nHwnd As Long, nProcID As Long) As Long
+
+Private application_ As Visio.Application
+Private document_ As Visio.Document
+Private reporter_ As Object
+Private bSilent_ As Boolean
+
+Private deferRel_ As Boolean
+Private deferRecalc_ As Boolean
+Private isPaused_ As Boolean
+
+Private bCloseOnFail_ As Boolean
+Private bOwnsDoc_ As Boolean
+Private bOwnsApp_ As Boolean
+
+Private Sub Class_Initialize()
+  Call ResetAll
+End Sub
+
+Private Sub Class_Terminate()
+  If application_ Is Nothing Then _
+    Exit Sub
+  ' Note: application could be owned by another Wrapper and already quit
+  On Error GoTo SKIP_RELEASE
+  If application_.Documents.Count = 0 Then _
+    Call ReleaseApplication
+SKIP_RELEASE:
+End Sub
+
+Public Function ResetAll()
+  Call ResetDocument
+  
+  deferRel_ = False
+  deferRecalc_ = False
+  bSilent_ = False
+End Function
+
+Public Function ResetDocument()
+  Set application_ = Nothing
+  Set document_ = Nothing
+  bOwnsDoc_ = False
+  bOwnsApp_ = False
+  bCloseOnFail_ = False
+  isPaused_ = False
+End Function
+
+' Reporter object should implement callback function Report(sMsg$, nFlags&)
+Public Function SetReporter(aReporter As Object)
+  Set reporter_ = aReporter
+End Function
+
+Public Property Get Document() As Visio.Document
+  Set Document = document_
+End Property
+
+Public Property Get Application() As Visio.Application
+  Set Application = application_
+End Property
+
+Public Property Get IsUIPaused() As Boolean
+  IsUIPaused = isPaused_
+End Property
+
+Public Function DisableMessages()
+  bSilent_ = True
+End Function
+
+Public Function EnableMessages()
+  bSilent_ = False
+End Function
+
+Public Function CreateApplication(Optional bIsVisible As Boolean = True) As Visio.Application
+  Call ResetDocument
+  Set application_ = CreateObject("Visio.Application")
+  bOwnsApp_ = True
+  application_.Visible = bIsVisible
+  Set CreateApplication = application_
+End Function
+
+Public Function SetApplication(target As Visio.Application)
+  If ObjPtr(application_) = ObjPtr(target) Then _
+    Exit Function
+  Call ResetDocument
+  Set application_ = target
+End Function
+
+Public Function SetDocument(target As Visio.Document, Optional bOwnership = False)
+  If ObjPtr(target) = ObjPtr(document_) Then
+    bOwnsDoc_ = bOwnership
+    Exit Function
+  End If
+  If Not target Is Nothing Then _
+    Call SetApplication(target.Application)
+  bOwnsDoc_ = bOwnership
+  Set document_ = target
+End Function
+
+Public Function PauseUI()
+  If application_ Is Nothing Then _
+    Exit Function
+  If document_ Is Nothing Then _
+    Exit Function
+    
+  Debug.Assert Not isPaused_
+  isPaused_ = True
+  deferRel_ = application_.DeferRelationshipRecalc
+  deferRecalc_ = application_.DeferRecalc
+  application_.ScreenUpdating = False
+  application_.DeferRecalc = True
+  application_.DeferRelationshipRecalc = True
+End Function
+
+Public Function ResumeUI()
+  If application_ Is Nothing Then _
+    Exit Function
+  If document_ Is Nothing Then _
+    Exit Function
+    
+  isPaused_ = False
+  application_.DeferRelationshipRecalc = deferRel_
+  application_.DeferRecalc = deferRecalc_
+  application_.ScreenUpdating = True
+End Function
+
+Public Function Run(sFunc$, ParamArray vArgs() As Variant)
+  ' Note: running code in Visio cannot return value, so use file IO instead if needed (pass output filename through args)
+  Dim nArgCount&: nArgCount = UBound(vArgs) - LBound(vArgs) + 1
+  Dim sCommand$: sCommand = "Call " & sFunc & "("
+  Dim nArg&
+  For nArg = 0 To nArgCount - 1 Step 1
+    If nArg <> 0 Then _
+      sCommand = sCommand & ", "
+    sCommand = sCommand & """" & CStr(vArgs(nArg)) & """"
+  Next nArg
+  sCommand = sCommand & ")"
+  Call Document.ExecuteLine(sCommand)
+End Function
+
+Public Function NewDocument(Optional sTemplate$ = vbNullString, _
+                            Optional bDefaultIfFail As Boolean = True) As Visio.Document
+  If Not document_ Is Nothing Then _
+    Exit Function
+  
+  If application_ Is Nothing Then
+    bCloseOnFail_ = True
+    Call CreateApplication
+  End If
+  
+  On Error GoTo TRY_DEFAULT
+  
+  Set document_ = application_.Documents.Add(sTemplate)
+  bOwnsDoc_ = True
+  Set NewDocument = document_
+  
+  Exit Function
+  
+TRY_DEFAULT:
+  If sTemplate <> vbNullString Then
+    Call Report("Íå óäàëîñü ñîçäàòü äîêóìåíò èç øàáëîíà " & sTemplate)
+    If Not bDefaultIfFail Then
+      If bCloseOnFail_ Then _
+        Call ReleaseApplication
+    Else
+      On Error GoTo ERR_DEFAULT
+      Set document_ = application_.Documents.Add("")
+      Set NewDocument = document_
+    End If
+    Exit Function
+  End If
+  
+ERR_DEFAULT:
+  Call Report("Íå óäàëîñü ñîçäàòü íîâûé äîêóìåíò èç áàçîâîãî øàáëîíà")
+  If bCloseOnFail_ Then _
+    Call ReleaseApplication
+End Function
+
+Public Function OpenDocument(sFile$, Optional nOpenFlags As Integer = 0) As Visio.Document
+' Note: Äîêóìåíòû Visio íå ïîääåðæèâàþò îïöèþ ReadOnly
+  If Not document_ Is Nothing Then _
+    Exit Function
+    
+  Dim bResetApplication As Boolean
+  bResetApplication = application_ Is Nothing
+  If bResetApplication Then _
+    Call DefaultApplication
+
+  If TryAlreadyOpened(sFile) Then
+    Set OpenDocument = document_
+    Exit Function
+  End If
+
+  If Not TestFile(sFile) Then _
+    GoTo SAFE_EXIT
+  
+  On Error GoTo SAFE_EXIT
+  Set document_ = application_.Documents.OpenEx(sFile, nOpenFlags)
+  On Error GoTo 0
+  
+  If Not document_ Is Nothing Then
+    bOwnsDoc_ = True
+    Set OpenDocument = document_
+  Else
+SAFE_EXIT:
+    bOwnsDoc_ = False
+    If bCloseOnFail_ Then _
+      Call KillApplication
+    If bResetApplication Then _
+      Set application_ = Nothing
+  End If
+End Function
+
+Public Function ReleaseApplication()
+  If bOwnsApp_ Then _
+    Call KillApplication
+  Call ResetDocument
+End Function
+
+Public Function ReleaseDocument(Optional bCloseApplication As Boolean = True, _
+                                Optional bSaveChanges As Boolean = False) As Boolean
+  ReleaseDocument = False
+  If document_ Is Nothing Then _
+    Exit Function
+  If Not bOwnsDoc_ Then
+    Set document_ = Nothing
+    ReleaseDocument = True
+    Exit Function
+  End If
+  
+  On Error GoTo EXIT_FUNC
+  
+  If (bSaveChanges And document_.Path <> vbNullString) Then
+    Call document_.OpenStencilWindow
+    Call document_.Save
+  End If
+  
+  Dim nInitialResponse&: nInitialResponse = application_.AlertResponse
+  application_.AlertResponse = vbNo
+  Call document_.Close
+  application_.AlertResponse = nInitialResponse
+  
+  On Error GoTo 0
+  
+  Set document_ = Nothing
+  ReleaseDocument = True
+ If bCloseApplication And application_.Documents.Count = 0 Then _
+    Call ReleaseApplication
+EXIT_FUNC:
+End Function
+
+Public Function SaveAs(sTargetName$) As Boolean
+  SaveAs = False
+  
+  If document_ Is Nothing Then _
+    Exit Function
+  
+  On Error GoTo RETURN_FALSE
+  Call document_.SaveAs(sTargetName)
+  On Error GoTo 0
+  
+  SaveAs = True
+  Exit Function
+RETURN_FALSE:
+End Function
+
+' ===========
+Private Function Report(sMsg$)
+  If bSilent_ Then
+    Debug.Print "VisioWrapper: " & sMsg
+    Exit Function
+  ElseIf reporter_ Is Nothing Then
+    Call MsgBox(sMsg, vbExclamation)
+  Else
+    Call reporter_.Report(sMsg, vbExclamation)
+  End If
+End Function
+
+Private Function DefaultApplication()
+  bOwnsApp_ = False
+  On Error GoTo CREATE_NEW_APPL
+  Set application_ = GetObject(, "Visio.Application")
+  On Error GoTo 0
+  Exit Function
+  
+CREATE_NEW_APPL:
+  Set application_ = CreateObject("Visio.Application")
+  bOwnsApp_ = True
+  bCloseOnFail_ = True
+  application_.Visible = True
+End Function
+
+Private Function KillApplication()
+  Const HIDE_SHELL = 0
+  Const WAIT_RETURN = True
+  
+  On Error GoTo OFFICE_QUIT
+  
+  Dim nThreadID&, nProcID&
+  nThreadID = GetWindowThreadProcessId(application_.WindowHandle32, nProcID)
+  
+  Dim iShell As Object: Set iShell = VBA.CreateObject("WScript.Shell")
+  If iShell.Run("TaskKill /F /PID " & nProcID, HIDE_SHELL, WAIT_RETURN) = 0 Then _
+    Exit Function
+
+OFFICE_QUIT:
+  Call application_.Quit
+End Function
+
+Private Function TryAlreadyOpened(sFile$) As Boolean
+  TryAlreadyOpened = False
+  
+  Set document_ = FindByName(sFile)
+  If document_ Is Nothing Then _
+    Exit Function
+  
+  bOwnsDoc_ = False
+  TryAlreadyOpened = True
+End Function
+
+Private Function TestFile(sFile$) As Boolean
+  Const ATTRIBUTE_READONLY = 1
+  TestFile = False
+
+  Dim fso As New Scripting.FileSystemObject
+  If Not fso.FileExists(sFile) Then
+    Call Report("Ôàéë íå íàéäåí: " & sFile)
+    Exit Function
+  End If
+  
+  If fso.GetFile(sFile).Attributes And ATTRIBUTE_READONLY Then
+    Call Report("Ôàéë ReadOnly: " & sFile)
+    Exit Function
+  End If
+  If IsFileInUse(sFile) Then
+    Call Report("Ôàéë çàáëîêèðîâàí: " & sFile)
+    Exit Function
+  End If
+  
+  TestFile = True
+End Function
+
+Private Function FindByName(sName$) As Visio.Document
+  Dim aDoc As Visio.Document
+  For Each aDoc In application_.Documents
+    If aDoc.FullName = sName Then
+      Set FindByName = aDoc
+      Exit Function
+    End If
+  Next aDoc
+End Function
+
+Private Function IsFileInUse(sFileName$) As Boolean
+  Dim nFile%: nFile = FreeFile
+  On Error Resume Next
+  
+  Open sFileName For Binary Access Read Lock Read Write As #nFile
+  Close #nFile
+  IsFileInUse = Err.Number > 0
+  
+  On Error GoTo 0
+End Function

api/API_WordWrapper.cls

@@ -0,0 +1,394 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_WordWrapper"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ================ Êëàññ-îáîëî÷êà äëÿ äîêóìåíòà MS Word =========================
+' Shared module version: 20220410
+' Tested in: TestCommons
+' Depends on:
+' Required reference: Scripting, Word
+Option Explicit
+
+Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal nHwnd As Long, nProcID As Long) As Long
+
+Private application_ As Word.Application
+Private document_ As Word.Document
+Private reporter_ As Object
+Private bSilent_ As Boolean
+
+Private isPaused_ As Boolean
+Private screenUpdate_ As Boolean
+Private proofing_ As Boolean
+
+Private bCloseOnFail_ As Boolean
+Private bOwnsDoc_ As Boolean
+Private bOwnsApp_ As Boolean
+
+Private Sub Class_Initialize()
+  Call ResetAll
+End Sub
+
+Private Sub Class_Terminate()
+  If application_ Is Nothing Then _
+    Exit Sub
+  ' Note: application could be owned by another Wrapper and already quit
+  On Error GoTo SKIP_RELEASE
+  If application_.Documents.Count = 0 Then _
+    Call ReleaseApplication
+SKIP_RELEASE:
+End Sub
+
+Public Function ResetAll()
+  Call ResetDocument
+  
+  screenUpdate_ = True
+  proofing_ = True
+  bSilent_ = False
+End Function
+
+Public Function ResetDocument()
+  Set application_ = Nothing
+  Set document_ = Nothing
+  bOwnsDoc_ = False
+  bOwnsApp_ = False
+  bCloseOnFail_ = False
+  isPaused_ = False
+End Function
+
+' Reporter object should implement callback function Report(sMsg$, nFlags&)
+Public Function SetReporter(aReporter As Object)
+  Set reporter_ = aReporter
+End Function
+
+Public Property Get Document() As Word.Document
+  Set Document = document_
+End Property
+
+Public Property Get Application() As Word.Application
+  Set Application = application_
+End Property
+
+Public Property Get IsUIPaused() As Boolean
+  IsUIPaused = isPaused_
+End Property
+
+Public Function DisableMessages()
+  bSilent_ = True
+End Function
+
+Public Function EnableMessages()
+  bSilent_ = False
+End Function
+
+Public Function CreateApplication(Optional bIsVisible As Boolean = True) As Word.Application
+  Call ResetDocument
+  Set application_ = CreateObject("Word.Application")
+  bOwnsApp_ = True
+  application_.Visible = bIsVisible
+  Set CreateApplication = application_
+End Function
+
+Public Function SetApplication(target As Word.Application)
+  If ObjPtr(application_) = ObjPtr(target) Then _
+    Exit Function
+  Call ResetDocument
+  Set application_ = target
+End Function
+
+Public Function SetDocument(target As Word.Document, Optional bOwnership = False)
+  If ObjPtr(target) = ObjPtr(document_) Then
+    bOwnsDoc_ = bOwnership
+    Exit Function
+  End If
+  If Not target Is Nothing Then _
+    Call SetApplication(target.Application)
+  bOwnsDoc_ = bOwnership
+  Set document_ = target
+End Function
+
+Public Function PauseUI()
+  If application_ Is Nothing Then _
+    Exit Function
+  If document_ Is Nothing Then _
+    Exit Function
+    
+  Debug.Assert Not isPaused_
+  isPaused_ = True
+  screenUpdate_ = application_.ScreenUpdating
+  proofing_ = document_.Range.NoProofing
+  application_.ScreenUpdating = False
+  document_.Range.NoProofing = True
+End Function
+
+Public Function ResumeUI()
+  If application_ Is Nothing Then _
+    Exit Function
+  If document_ Is Nothing Then _
+    Exit Function
+    
+  isPaused_ = False
+  application_.ScreenUpdating = screenUpdate_
+  document_.Range.NoProofing = proofing_
+  Call application_.ScreenRefresh
+End Function
+
+Public Function Run(sCommand$, ParamArray vArgs() As Variant) As Variant
+  Dim nArgCount&: nArgCount = UBound(vArgs) - LBound(vArgs) + 1
+  Select Case nArgCount
+  Case 0: Run = application_.Run(sCommand)
+  Case 1: Run = application_.Run(sCommand, vArgs(0))
+  Case 2: Run = application_.Run(sCommand, vArgs(0), vArgs(1))
+  Case 3: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2))
+  Case 4: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2), vArgs(3))
+  Case 5: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4))
+  Case 6: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5))
+  Case 7: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6))
+  End Select
+End Function
+
+Public Function NewDocument(Optional sTemplate$ = vbNullString, _
+                            Optional bDefaultIfFail As Boolean = True) As Word.Document
+  If Not document_ Is Nothing Then _
+    Exit Function
+    
+  If application_ Is Nothing Then
+    bCloseOnFail_ = True
+    Call CreateApplication
+  End If
+  
+  On Error GoTo TRY_DEFAULT
+  
+  Set document_ = application_.Documents.Add(sTemplate)
+  bOwnsDoc_ = True
+  Set NewDocument = document_
+  
+  Exit Function
+  
+TRY_DEFAULT:
+  If sTemplate <> vbNullString Then
+    Call Report("Íå óäàëîñü ñîçäàòü äîêóìåíò èç øàáëîíà " & sTemplate)
+    If Not bDefaultIfFail Then
+      If bCloseOnFail_ Then _
+        Call ReleaseApplication
+    Else
+      On Error GoTo ERR_DEFAULT
+      Set document_ = application_.Documents.Add
+      Set NewDocument = document_
+    End If
+    Exit Function
+  End If
+  
+ERR_DEFAULT:
+  Call Report("Íå óäàëîñü ñîçäàòü íîâûé äîêóìåíò èç áàçîâîãî øàáëîíà")
+  If bCloseOnFail_ Then _
+    Call ReleaseApplication
+End Function
+
+Public Function OpenDocument(sFile$, _
+                              Optional bReadOnly As Boolean = False, _
+                              Optional bTrackMRU As Boolean = False) As Word.Document
+  If Not document_ Is Nothing Then _
+    Exit Function
+    
+  Dim bResetApplication As Boolean
+  bResetApplication = application_ Is Nothing
+  If bResetApplication Then _
+    Call DefaultApplication
+    
+  If TryAlreadyOpened(sFile, bReadOnly) Then
+    Set OpenDocument = document_
+    Exit Function
+  End If
+    
+  If Not TestFile(sFile, bReadOnly) Then _
+    GoTo SAFE_EXIT
+    
+  On Error GoTo SAFE_EXIT
+  Set document_ = application_.Documents.Open(sFile, AddToRecentFiles:=bTrackMRU, ReadOnly:=bReadOnly)
+  On Error GoTo 0
+  
+  If Not document_ Is Nothing Then
+    bOwnsDoc_ = True
+    Set OpenDocument = document_
+  Else
+SAFE_EXIT:
+    bOwnsDoc_ = False
+    If bCloseOnFail_ Then _
+      Call KillApplication
+    If bResetApplication Then _
+      Set application_ = Nothing
+  End If
+End Function
+
+Public Function ReleaseApplication()
+  If bOwnsApp_ Then _
+    Call KillApplication
+  Call ResetDocument
+End Function
+
+Public Function ReleaseDocument(Optional bCloseApplication As Boolean = True, _
+                                Optional bSaveChanges As Boolean = False) As Boolean
+  ReleaseDocument = False
+  If document_ Is Nothing Then _
+    Exit Function
+  If Not bOwnsDoc_ Then
+    Set document_ = Nothing
+    ReleaseDocument = True
+    Exit Function
+  End If
+  
+  On Error GoTo EXIT_FUNC
+  Call document_.Close(SaveChanges:=(bSaveChanges And document_.Path <> vbNullString))
+  On Error GoTo 0
+  
+  Set document_ = Nothing
+  ReleaseDocument = True
+  If (bCloseApplication And application_.Documents.Count = 0) Then _
+    Call ReleaseApplication
+EXIT_FUNC:
+End Function
+
+Public Function SaveAs(sTargetName$) As Boolean
+  SaveAs = False
+  
+  If document_ Is Nothing Then _
+    Exit Function
+  
+  On Error GoTo RETURN_FALSE
+  
+  Dim fso As New Scripting.FileSystemObject
+  Dim nFormat As WdSaveFormat
+  If GetSaveFormat(fso.GetExtensionName(sTargetName), nFormat) Then
+    Call document_.SaveAs2(sTargetName, FileFormat:=nFormat)
+  Else
+    Call document_.SaveAs2(sTargetName)
+  End If
+  
+  On Error GoTo 0
+  
+  SaveAs = True
+  Exit Function
+RETURN_FALSE:
+End Function
+
+' =======
+Private Function Report(sMsg$)
+  If bSilent_ Then
+    Debug.Print "WordWrapper: " & sMsg
+    Exit Function
+  ElseIf reporter_ Is Nothing Then
+    Call MsgBox(sMsg, vbExclamation)
+  Else
+    Call reporter_.Report(sMsg, vbExclamation)
+  End If
+End Function
+
+Private Function DefaultApplication()
+  bOwnsApp_ = False
+  On Error GoTo CREATE_NEW_APPL
+  Set application_ = GetObject(, "Word.Application")
+  On Error GoTo 0
+  Exit Function
+  
+CREATE_NEW_APPL:
+  Set application_ = CreateObject("Word.Application")
+  bOwnsApp_ = True
+  bCloseOnFail_ = True
+  application_.Visible = True
+End Function
+
+Private Function KillApplication()
+  Const HIDE_SHELL = 0
+  Const WAIT_RETURN = True
+  
+  On Error GoTo OFFICE_QUIT
+  
+  Dim nThreadID&, nProcID&
+  Call application_.Documents.Add ' Create new document for ActiveWindow to become available
+  nThreadID = GetWindowThreadProcessId(application_.ActiveWindow.Hwnd, nProcID)
+  
+  Dim iShell As Object: Set iShell = VBA.CreateObject("WScript.Shell")
+  If iShell.Run("TaskKill /F /PID " & nProcID, HIDE_SHELL, WAIT_RETURN) = 0 Then _
+    Exit Function
+
+OFFICE_QUIT:
+  Call application_.Quit(SaveChanges:=False)
+End Function
+
+Private Function TryAlreadyOpened(sFile$, bReadOnly As Boolean) As Boolean
+  TryAlreadyOpened = False
+  
+  Set document_ = FindByName(sFile)
+  If document_ Is Nothing Then _
+    Exit Function
+  If document_.ReadOnly And Not bReadOnly Then
+    Set document_ = Nothing
+    Exit Function
+  End If
+  
+  bOwnsDoc_ = False
+  TryAlreadyOpened = True
+End Function
+
+Private Function TestFile(sFile$, bReadOnly As Boolean) As Boolean
+  Const ATTRIBUTE_READONLY = 1
+  TestFile = False
+  
+  Dim fso As New Scripting.FileSystemObject
+  If Not fso.FileExists(sFile) Then
+    Call Report("Ôàéë íå íàéäåí: " & sFile)
+    Exit Function
+  End If
+  
+  If Not bReadOnly Then
+    If fso.GetFile(sFile).Attributes And ATTRIBUTE_READONLY Then
+      Call Report("Ôàéë ReadOnly: " & sFile)
+      Exit Function
+    End If
+    If IsFileInUse(sFile) Then
+      Call Report("Ôàéë çàáëîêèðîâàí: " & sFile)
+      Exit Function
+    End If
+  End If
+  
+  TestFile = True
+End Function
+
+Private Function FindByName(sName$) As Word.Document
+  Dim aDoc As Word.Document
+  For Each aDoc In application_.Documents
+    If aDoc.FullName = sName Then
+      Set FindByName = aDoc
+      Exit Function
+    End If
+  Next aDoc
+End Function
+
+Private Function IsFileInUse(sFileName$) As Boolean
+  Dim nFile%: nFile = FreeFile
+  On Error Resume Next
+  
+  Open sFileName For Binary Access Read Lock Read Write As #nFile
+  Close #nFile
+  IsFileInUse = Err.Number > 0
+  
+  On Error GoTo 0
+End Function
+
+Private Function GetSaveFormat(sExtension$, ByRef nFormat As WdSaveFormat) As Boolean
+  GetSaveFormat = True
+  Select Case VBA.UCase(sExtension)
+    Case "DOCX": nFormat = wdFormatXMLDocument
+    Case "DOCM": nFormat = wdFormatXMLDocumentMacroEnabled
+    Case "DOTX": nFormat = wdFormatXMLTemplate
+    Case "DOTM": nFormat = wdFormatXMLTemplateMacroEnabled
+    Case "TXT": nFormat = wdFormatText
+    Case "PDF": nFormat = wdFormatPDF
+    Case Else: GetSaveFormat = False
+  End Select
+End Function

api/API_XLWrapper.cls

@@ -0,0 +1,412 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_XLWrapper"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ================ Êëàññ-îáîëî÷êà äëÿ äîêóìåíòà MS Excel =========================
+' Shared module version: 20220421
+' Tested in: TestCommons
+' Depends on:
+' Required reference: Scripting, Excel
+Option Explicit
+
+Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal nHwnd As Long, nProcID As Long) As Long
+
+Private application_ As Excel.Application
+Private document_ As Excel.Workbook
+Private reporter_ As Object
+Private bSilent_ As Boolean
+
+Private isPaused_ As Boolean
+Private calculation_ As Excel.XlCalculation
+
+Private bCloseOnFail_ As Boolean
+Private bOwnsDoc_ As Boolean
+Private bOwnsApp_ As Boolean
+
+Private Sub Class_Initialize()
+  Call ResetAll
+End Sub
+
+Private Sub Class_Terminate()
+  If application_ Is Nothing Then _
+    Exit Sub
+  ' Note: application could be owned by another Wrapper and already quit
+  On Error GoTo SKIP_RELEASE
+  If application_.Workbooks.Count = 0 Then _
+    Call ReleaseApplication
+SKIP_RELEASE:
+End Sub
+
+Public Function ResetAll()
+  Call ResetDocument
+
+  calculation_ = xlCalculationAutomatic
+  bSilent_ = False
+End Function
+
+Public Function ResetDocument()
+  Set application_ = Nothing
+  Set document_ = Nothing
+  bOwnsDoc_ = False
+  bOwnsApp_ = False
+  bCloseOnFail_ = False
+  isPaused_ = False
+End Function
+
+' Reporter object should implement callback function Report(sMsg$, nFlags&)
+Public Function SetReporter(aReporter As Object)
+  Set reporter_ = aReporter
+End Function
+
+Public Property Get Document() As Excel.Workbook
+  Set Document = document_
+End Property
+
+Public Property Get Application() As Excel.Application
+  Set Application = application_
+End Property
+
+Public Property Get IsUIPaused() As Boolean
+  IsUIPaused = isPaused_
+End Property
+
+Public Function DisableMessages()
+  bSilent_ = True
+End Function
+
+Public Function EnableMessages()
+  bSilent_ = False
+End Function
+
+Public Function CreateApplication(Optional bIsVisible As Boolean = True) As Excel.Application
+  Call ResetDocument
+  Set application_ = CreateObject("Excel.Application")
+  bOwnsApp_ = True
+  application_.Visible = bIsVisible
+  Set CreateApplication = application_
+End Function
+
+Public Function SetApplication(target As Excel.Application)
+  If ObjPtr(application_) = ObjPtr(target) Then _
+    Exit Function
+  Call ResetDocument
+  Set application_ = target
+End Function
+
+Public Function SetDocument(target As Excel.Workbook, Optional bOwnership = False)
+  If ObjPtr(target) = ObjPtr(document_) Then
+    bOwnsDoc_ = bOwnership
+    Exit Function
+  End If
+  If Not target Is Nothing Then _
+    Call SetApplication(target.Application)
+  bOwnsDoc_ = bOwnership
+  Set document_ = target
+End Function
+
+Public Function PauseUI()
+  If application_ Is Nothing Then _
+    Exit Function
+  If document_ Is Nothing Then _
+    Exit Function
+    
+  Debug.Assert Not isPaused_
+  isPaused_ = True
+  calculation_ = application_.Calculation
+  application_.Calculation = xlCalculationManual
+  application_.ScreenUpdating = False
+  application_.EnableEvents = False
+  application_.AskToUpdateLinks = False
+  application_.Cursor = xlWait
+End Function
+
+Public Function ResumeUI()
+  If application_ Is Nothing Then _
+    Exit Function
+  If document_ Is Nothing Then _
+    Exit Function
+    
+  isPaused_ = False
+  application_.Cursor = xlNormal
+  application_.AskToUpdateLinks = True
+  application_.EnableEvents = True
+  application_.ScreenUpdating = True
+  application_.Calculation = calculation_
+End Function
+
+Public Function Run(sFunction$, ParamArray vArgs() As Variant) As Variant
+  Dim sCommand$: sCommand = "'" & document_.Name & "'" & "!" & sFunction
+  Dim nArgCount&: nArgCount = UBound(vArgs) - LBound(vArgs) + 1
+  Select Case nArgCount
+  Case 0: Run = application_.Run(sCommand)
+  Case 1: Run = application_.Run(sCommand, vArgs(0))
+  Case 2: Run = application_.Run(sCommand, vArgs(0), vArgs(1))
+  Case 3: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2))
+  Case 4: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2), vArgs(3))
+  Case 5: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4))
+  Case 6: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5))
+  Case 7: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6))
+  End Select
+End Function
+
+Public Function NewDocument(Optional sTemplate$ = vbNullString, _
+                            Optional bDefaultIfFail As Boolean = True) As Excel.Workbook
+  If Not document_ Is Nothing Then _
+    Exit Function
+  If application_ Is Nothing Then
+    bCloseOnFail_ = True
+    Call CreateApplication
+  End If
+  
+  On Error GoTo TRY_DEFAULT
+  
+  Set document_ = application_.Workbooks.Add(sTemplate)
+  bOwnsDoc_ = True
+  Set NewDocument = document_
+  
+  Exit Function
+  
+TRY_DEFAULT:
+  If sTemplate <> vbNullString Then
+    Call Report("Íå óäàëîñü ñîçäàòü äîêóìåíò èç øàáëîíà " & sTemplate)
+    If Not bDefaultIfFail Then
+      If bCloseOnFail_ Then _
+        Call ReleaseApplication
+    Else
+      On Error GoTo ERR_DEFAULT
+      Set document_ = application_.Workbooks.Add
+      Set NewDocument = document_
+    End If
+    Exit Function
+  End If
+  
+ERR_DEFAULT:
+  Call Report("Íå óäàëîñü ñîçäàòü íîâûé äîêóìåíò èç áàçîâîãî øàáëîíà")
+  If bCloseOnFail_ Then _
+    Call ReleaseApplication
+End Function
+
+Public Function OpenDocument(sFile$, _
+                              Optional bReadOnly As Boolean = False, _
+                              Optional bTrackMRU As Boolean = False, _
+                              Optional bIgnoreFolder As Boolean = False) As Excel.Workbook
+  If Not document_ Is Nothing Then _
+    Exit Function
+    
+  Dim bResetApplication As Boolean
+  bResetApplication = application_ Is Nothing
+  If bResetApplication Then _
+    Call DefaultApplication
+    
+  If TryAlreadyOpened(sFile, bReadOnly, bIgnoreFolder) Then
+    Set OpenDocument = document_
+    Exit Function
+  End If
+  
+  If Not TestFile(sFile, bReadOnly, bIgnoreFolder) Then _
+    GoTo SAFE_EXIT
+  
+  On Error GoTo SAFE_EXIT
+  If sFile Like "*.csv" Then
+    Set document_ = application_.Workbooks.Open(sFile, addToMRU:=bTrackMRU, ReadOnly:=bReadOnly, Editable:=True, Format:=6, Delimiter:=",")
+  Else
+    Set document_ = application_.Workbooks.Open(sFile, addToMRU:=bTrackMRU, ReadOnly:=bReadOnly, Editable:=True)
+  End If
+  On Error GoTo 0
+  
+  If Not document_ Is Nothing Then
+    bOwnsDoc_ = True
+    Set OpenDocument = document_
+  Else
+SAFE_EXIT:
+    bOwnsDoc_ = False
+    If bCloseOnFail_ Then _
+      Call KillApplication
+    If bResetApplication Then _
+      Set application_ = Nothing
+  End If
+End Function
+
+Public Function ReleaseApplication()
+  If bOwnsApp_ Then _
+    Call KillApplication
+  Call ResetDocument
+End Function
+
+Public Function ReleaseDocument(Optional bCloseApplication As Boolean = True, _
+                            Optional bSaveChanges As Boolean = False) As Boolean
+  ReleaseDocument = False
+  If document_ Is Nothing Then _
+    Exit Function
+  If Not bOwnsDoc_ Then
+    Set document_ = Nothing
+    ReleaseDocument = True
+    Exit Function
+  End If
+
+  On Error GoTo EXIT_FUNC
+  Call document_.Close(SaveChanges:=(bSaveChanges And document_.Path <> vbNullString))
+  On Error GoTo 0
+  
+  Set document_ = Nothing
+  ReleaseDocument = True
+  If bCloseApplication And application_.Workbooks.Count = 0 Then _
+    Call ReleaseApplication
+EXIT_FUNC:
+End Function
+
+Public Function SaveAs(sTargetName$) As Boolean
+  SaveAs = False
+
+  If document_ Is Nothing Then _
+    Exit Function
+    
+  Dim bDisplayAlerts As Boolean: bDisplayAlerts = application_.DisplayAlerts
+  application_.DisplayAlerts = False
+
+  On Error GoTo RETURN_FALSE
+
+  Dim fso As New Scripting.FileSystemObject
+  Dim nFormat As Excel.XlFileFormat
+  If GetSaveFormat(fso.GetExtensionName(sTargetName), nFormat) Then
+    Call document_.SaveAs(sTargetName, FileFormat:=nFormat, ConflictResolution:=xlLocalSessionChanges)
+  Else
+    Call document_.SaveAs(sTargetName, ConflictResolution:=xlLocalSessionChanges)
+  End If
+
+  On Error GoTo 0
+  
+  application_.DisplayAlerts = bDisplayAlerts
+  SaveAs = True
+  Exit Function
+  
+RETURN_FALSE:
+  application_.DisplayAlerts = bDisplayAlerts
+End Function
+
+' ========
+Private Function Report(sMsg$)
+  If bSilent_ Then
+    Debug.Print "XLWrapper: " & sMsg
+    Exit Function
+  ElseIf reporter_ Is Nothing Then
+    Call MsgBox(sMsg, vbExclamation)
+  Else
+    Call reporter_.Report(sMsg, vbExclamation)
+  End If
+End Function
+
+Private Function DefaultApplication()
+  bOwnsApp_ = False
+  On Error GoTo CREATE_NEW_APPL
+  Set application_ = GetObject(, "Excel.Application")
+  On Error GoTo 0
+  Exit Function
+  
+CREATE_NEW_APPL:
+  Set application_ = CreateObject("Excel.Application")
+  bOwnsApp_ = True
+  bCloseOnFail_ = True
+  application_.Visible = True
+End Function
+
+Private Function KillApplication()
+  Const HIDE_SHELL = 0
+  Const WAIT_RETURN = True
+  
+  On Error GoTo OFFICE_QUIT
+  
+  Dim nThreadID&, nProcID&
+  nThreadID = GetWindowThreadProcessId(application_.Hwnd, nProcID)
+  
+  Dim iShell As Object: Set iShell = VBA.CreateObject("WScript.Shell")
+  If iShell.Run("TaskKill /F /PID " & nProcID, HIDE_SHELL, WAIT_RETURN) = 0 Then _
+    Exit Function
+
+OFFICE_QUIT:
+  Call application_.Quit
+End Function
+
+Private Function TryAlreadyOpened(sFile$, bReadOnly As Boolean, bIgnoreFolder As Boolean) As Boolean
+  TryAlreadyOpened = False
+  
+  Dim fso As New Scripting.FileSystemObject
+  Set document_ = FindByName(IIf(bIgnoreFolder, fso.GetFileName(sFile), sFile), bIgnoreFolder)
+  If document_ Is Nothing Then _
+    Exit Function
+  If document_.ReadOnly And Not bReadOnly Then
+    Set document_ = Nothing
+    Exit Function
+  End If
+  
+  bOwnsDoc_ = False
+  TryAlreadyOpened = True
+End Function
+
+Private Function TestFile(sFile$, bReadOnly As Boolean, bIgnoreFolder As Boolean) As Boolean
+  Const ATTRIBUTE_READONLY = 1
+  TestFile = False
+  
+  Dim fso As New Scripting.FileSystemObject
+  If Not bIgnoreFolder And Not fso.FileExists(sFile) Then
+    Call Report("Ôàéë íå íàéäåí: " & sFile)
+    Exit Function
+  End If
+  
+  If Not bReadOnly And fso.FileExists(sFile) Then
+    If fso.GetFile(sFile).Attributes And ATTRIBUTE_READONLY Then
+      Call Report("Ôàéë ReadOnly: " & sFile)
+      Exit Function
+    End If
+    If Not bIgnoreFolder Then
+      If IsFileInUse(sFile) Then
+        Call Report("Ôàéë çàáëîêèðîâàí: " & sFile)
+        Exit Function
+      End If
+    End If
+  End If
+  
+  TestFile = True
+End Function
+
+Private Function FindByName(sName$, bIgnoreFolder As Boolean) As Excel.Workbook
+  Dim aBook As Excel.Workbook
+  For Each aBook In application_.Workbooks
+    If bIgnoreFolder And aBook.Name = sName Or _
+        Not bIgnoreFolder And aBook.FullName = sName Then
+      Set FindByName = aBook
+      Exit Function
+    End If
+  Next aBook
+End Function
+
+Private Function IsFileInUse(sFileName$) As Boolean
+  Dim nFile%: nFile = FreeFile
+  On Error Resume Next
+  
+  Open sFileName For Binary Access Read Lock Read Write As #nFile
+  Close #nFile
+  IsFileInUse = Err.Number > 0
+  
+  On Error GoTo 0
+End Function
+
+Private Function GetSaveFormat(sExtension$, ByRef nFormat As Excel.XlFileFormat) As Boolean
+  GetSaveFormat = True
+  Select Case VBA.UCase(sExtension)
+    Case "XLSX": nFormat = xlOpenXMLWorkbook
+    Case "XLSM": nFormat = xlOpenXMLWorkbookMacroEnabled
+    Case "XLTX": nFormat = xlOpenXMLTemplate
+    Case "XLTM": nFormat = xlOpenXMLTemplateMacroEnabled
+    Case "XLAM": nFormat = xlOpenXMLAddIn
+    Case "TXT": nFormat = xlText
+    Case "CSV": nFormat = xlCSV
+    Case "PDF": nFormat = xlTypePDF
+    Case Else: GetSaveFormat = False
+  End Select
+End Function

api/ex_ConceptCore.bas

@@ -0,0 +1,117 @@
+Attribute VB_Name = "ex_ConceptCore"
+'================ CCL wrapper =========================
+' Shared module version: 20220713
+' Tested in:
+' Depends on:
+' Required reference:
+Option Private Module
+Option Explicit
+
+Private Const CONCEPT_DLL_LOCATION = "C:\Tools\dll"
+
+#If Win64 Then
+  Private Const CCL_DLL_NAME = "ConceptCore64.dll"
+  Private Declare PtrSafe Function ConvertToASCII Lib "ConceptCore64.dll" ( _
+    ByRef vResult As Variant, ByRef vText As Variant) As Long
+  Private Declare PtrSafe Function ConvertToMath Lib "ConceptCore64.dll" ( _
+    ByRef vResult As Variant, ByVal sText As String) As Long
+  Private Declare PtrSafe Function ASTasText Lib "ConceptCore64.dll" ( _
+    ByRef vResult As Variant, ByVal sText As String) As Long
+#Else
+  Private Const CCL_DLL_NAME = "ConceptCore32.dll"
+  Private Declare PtrSafe Function ConvertToASCII Lib "ConceptCore32.dll" ( _
+    ByRef vResult As Variant, ByRef vText As Variant) As Long
+  Private Declare PtrSafe Function ConvertToMath Lib "ConceptCore32.dll" ( _
+    ByRef vResult As Variant, ByVal sText As String) As Long
+  Private Declare PtrSafe Function ASTasText Lib "ConceptCore32.dll" ( _
+    ByRef vResult As Variant, ByVal sText As String) As Long
+#End If
+
+Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal sLibrary As String) As Long
+Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal nLibraryHandle As Long) As Long
+Private Const HRESULT_OK = 0
+
+Private g_IsConceptLoaded As Boolean
+
+Public Function LoadConceptCore()
+  If g_IsConceptLoaded Then _
+    Exit Function
+  g_IsConceptLoaded = True
+  
+  If LoadLibrary(CCL_DLL_NAME) <> 0 Then _
+    Exit Function
+    
+  If LoadLibrary(CONCEPT_DLL_LOCATION & "\" & CCL_DLL_NAME) <> 0 Then _
+    Exit Function
+    
+  ' TODO: remove fallback after some time
+  ' fallback path for earlier versions of distribution
+  If LoadLibrary(VBA.Environ("USERPROFILE") & "\.concept\dll\" & CCL_DLL_NAME) = 0 Then _
+    Call Err.Raise(1, Description:="Could not load " & CCL_DLL_NAME)
+End Function
+
+Public Function UnloadConceptCore()
+  If Not g_IsConceptLoaded Then _
+    Exit Function
+  Dim nHandle&: nHandle = LoadLibrary(CCL_DLL_NAME)
+  Call FreeLibrary(nHandle)
+End Function
+
+Public Function MathToASCII(sText$) As String
+  On Error GoTo HANDLE_ERROR
+  
+  LoadConceptCore
+  
+  Dim vText As Variant: vText = sText
+  Dim vResult As Variant
+  If ConvertToASCII(vResult, vText) <> HRESULT_OK Then _
+    MathToASCII = "ERR: "
+  MathToASCII = MathToASCII & vResult
+  
+  On Error GoTo 0
+  Exit Function
+  
+HANDLE_ERROR:
+  Debug.Print Err.Description
+  MathToASCII = Err.Description
+  On Error GoTo 0
+End Function
+
+Public Function ASCIItoMath(sText$) As String
+  On Error GoTo HANDLE_ERROR
+  
+  LoadConceptCore
+  
+  Dim vResult As Variant
+  If ConvertToMath(vResult, sText) <> HRESULT_OK Then _
+    ASCIItoMath = "ERR: "
+  ASCIItoMath = ASCIItoMath & " " & vResult
+  
+  On Error GoTo 0
+  Exit Function
+  
+HANDLE_ERROR:
+  Debug.Print Err.Description
+  ASCIItoMath = Err.Description
+  On Error GoTo 0
+End Function
+
+Public Function ASCIItoAST(sText$) As String
+  On Error GoTo HANDLE_ERROR
+
+  LoadConceptCore
+  
+  Dim vResult As Variant
+  If ASTasText(vResult, sText) <> HRESULT_OK Then _
+    ASCIItoAST = "ERR: "
+  ASCIItoAST = ASCIItoAST & vResult
+  
+  On Error GoTo 0
+  Exit Function
+  
+HANDLE_ERROR:
+  Debug.Print Err.Description
+  ASCIItoAST = Err.Description
+  On Error GoTo 0
+End Function
+

api/ex_Metadata.bas

@@ -0,0 +1,40 @@
+Attribute VB_Name = "ex_Metadata"
+'================ Ìîäóëü äëÿ ðàáîòû ñ äàííûìè äîêóìåíòà =============
+' Shared module version: 20210506
+' Depends on:
+' Required reference: Scripting
+Option Private Module
+Option Explicit
+
+Public Function MetadataExists(iDoc As Object, varName$) As Boolean
+  Dim aVar As Variant
+  For Each aVar In iDoc.Variables
+    If aVar.Name = varName Then
+      MetadataExists = True
+      Exit Function
+    End If
+  Next aVar
+  MetadataExists = False
+End Function
+
+Public Function GetMetadata(iDoc As Object, varName$) As Variant
+  Dim aVar As Variant
+  For Each aVar In iDoc.Variables
+    If aVar.Name = varName Then
+      GetMetadata = aVar.Value
+      Exit Function
+    End If
+  Next aVar
+  GetMetadata = ""
+End Function
+
+Public Function SetMetadata(iDoc As Object, varName$, val As Variant)
+  Dim aVar As Variant
+  For Each aVar In iDoc.Variables
+    If aVar.Name = varName Then
+      aVar.Value = val
+      Exit Function
+    End If
+  Next aVar
+  Call iDoc.Variables.Add(varName, val)
+End Function

api/ex_Python.bas

@@ -0,0 +1,125 @@
+Attribute VB_Name = "ex_Python"
+' ======== Python runner extension ========
+' Shared module version: 20240330
+' Tested in: PythonManager
+' Depends on: ex_VBA, ex_WinAPI, API_Config
+' Required reference: Scripting
+Option Private Module
+Option Explicit
+
+' Switch flag for Debug purposes
+Private Const SHOW_PYTHON = False
+
+Public Const PY_KEY_INTERPRETER = "Python3"
+Public Const PY_KEY_SOURCE_PATH = "PythonImports"
+
+Public Const PY_MODULE_TEXT = "cctext"
+Public Const PY_MODULE_UTILS = "vbatopy"
+
+Public Const PY_DEFVALUE_INTERPRETER = "C:\Tools\Python312-venv\Scripts\python.exe"
+
+Public Function AccessPython() As API_Python
+  Static s_Python As API_Python
+  If s_Python Is Nothing Then
+    Set s_Python = New API_Python
+    Call s_Python.Init( _
+      iPython:=ConceptConfig.GetValue(PY_KEY_INTERPRETER), _
+      sModules:=OfficeActivePath & ";" & ConceptConfig.GetValue(PY_KEY_SOURCE_PATH), _
+      bDoDebug:=SHOW_PYTHON)
+  End If
+  Set AccessPython = s_Python
+End Function
+
+Public Function ConceptConfig() As API_Config
+  Dim iConfig As New API_Config
+  Set ConceptConfig = iConfig
+  If Not iConfig.LoadFromFile(ConceptConfigPath()) Then _
+    Call LoadDefaultConfig(iConfig)
+End Function
+
+' Runs the Python command, e.g.: Call RunPython("import bar; bar.foo()", ThisWorkbook.Path)
+Public Function RunPyStandalone(sPyCommand$, Optional sWorkDir$ = vbNullString) As Long
+  Dim iConfig As API_Config: Set iConfig = ConceptConfig
+  Dim iPython$: iPython = iConfig.GetValue(PY_KEY_INTERPRETER)
+  Dim sSource$
+  If Not sWorkDir = vbNullString Then _
+    sSource = sWorkDir & ";"
+  sSource = sSource & iConfig.GetValue(PY_KEY_SOURCE_PATH)
+  If sSource <> "" Then _
+    sSource = sSource & ";"
+  sSource = VBA.Replace(sSource, "&", "^&")
+  sSource = VBA.Replace(sSource, "\", "\\")
+  
+  Dim sChangeDir$: sChangeDir = GenerateCDCommandFor(iPython)
+  Dim sExtendedPyCommand$: sExtendedPyCommand = Fmt( _
+    "{1} & ""{2}"" -B -c " & _
+    """import sys, os; sys.path[0:0]=os.path.normcase(os.path.expandvars(\""{3}\"")).split(';'); " & _
+    "{4}""", _
+      sChangeDir, iPython, sSource, sPyCommand)
+  
+  RunPyStandalone = PyExecute(sExtendedPyCommand)
+End Function
+
+' Runs a Python executable that has been frozen by PyInstaller and the like
+' Call RunFrozenPython("C:\path\to\frozen_executable.exe", "arg1 arg2")
+Public Function RunPyFrozen(iPython$, Optional sArgs$ = vbNullString) As Long
+  Dim sChangeDir$: sChangeDir = GenerateCDCommandFor(iPython)
+  Dim sPyCommand$: sPyCommand = Fmt("{1} & ""{2}"" {3}", sChangeDir, iPython, sArgs)
+  RunPyFrozen = PyExecute(sPyCommand)
+End Function
+
+Public Function ConceptConfigPath() As String
+  ConceptConfigPath = VBA.Environ$("USERPROFILE") & "\.concept\concept-options.json"
+End Function
+
+' ========
+Private Function PyExecute(sPyCommand$) As Long
+  Dim sLog$: sLog = GetLogFile()
+  
+  Dim sShellCommand$: sShellCommand = Fmt("cmd.exe /C {1} 2> ""{3}""", _
+                                          sPyCommand, sLog)
+  
+  Dim nWindowStyle%: nWindowStyle = IIf(SHOW_PYTHON, 1, 0)
+  Dim iShell As Object: Set iShell = CreateObject("WScript.Shell")
+  Dim nExitCode&: nExitCode = iShell.Run(sShellCommand, nWindowStyle, True)
+
+  If nExitCode <> 0 Then
+    Call MsgBox(ReadTextFile(sLog), vbCritical)
+    PyExecute = -1
+  End If
+
+  On Error Resume Next
+  Call Kill(sLog)
+  On Error GoTo 0
+
+  Set iShell = Nothing
+End Function
+
+Private Function LoadDefaultConfig(ByRef iConfig As API_Config)
+  Call iConfig.SetValue(PY_KEY_INTERPRETER, PY_DEFVALUE_INTERPRETER)
+  Call iConfig.SetValue(PY_KEY_SOURCE_PATH, "")
+End Function
+
+Private Function GenerateCDCommandFor(sFile$) As String
+  Dim fso As New Scripting.FileSystemObject
+  GenerateCDCommandFor = Fmt("{1} & cd ""{2}""", VBA.Left(sFile, 2), fso.GetParentFolderName(sFile$))
+End Function
+
+Private Function GetLogFile() As String
+  GetLogFile = Fmt("{1}\pymanager-{2}.log", VBA.Environ("Temp"), GetCurrentProcessId())
+End Function
+
+Private Function ReadTextFile(sFile$) As String
+  Dim adoStream As Object: Set adoStream = CreateObject("ADODB.Stream")
+  adoStream.Charset = "utf-8"
+  Call adoStream.Open
+  
+  On Error GoTo ERROR_FILE
+  Call adoStream.LoadFromFile(sFile)
+  On Error GoTo 0
+  
+  ReadTextFile = adoStream.ReadText
+  
+ERROR_FILE:
+  Call adoStream.Close
+End Function

api/ex_WinAPI.bas

@@ -0,0 +1,541 @@
+Attribute VB_Name = "ex_WinAPI"
+' ================ Ìîäóëü äëÿ ðàáîòû ñ ôóíêöèÿìè óðîâíÿ ïðèëîæåíèÿ =============
+' Shared module version: 20220812
+' Tested in: TestCommons
+' Depends on:
+' Required reference: Scripting, Shell32
+Option Private Module
+Option Explicit
+
+Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal nMilliseconds As LongPtr)
+Public Declare PtrSafe Function GetCurrentProcessId Lib "kernel32" () As Long
+Public Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal nHwnd As Long, nProcID As Long) As Long
+Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
+Public Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" _
+  (ByVal nHwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
+  
+Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal nHwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
+Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal nHwnd As Long, ByVal nDEvent As Long) As Long
+
+Private Const DATAOBJECT_BINDING$ = "new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}" ' ID Äëÿ îáúåêòà DataObject
+
+Private Declare PtrSafe Function BringWindowToTop Lib "user32" (ByVal nHwnd As Long) As Long
+Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal nHwnd As Long) As Long
+
+Private Declare PtrSafe Function GetCommandLine Lib "kernel32" Alias "GetCommandLineW" () As LongPtr
+Private Declare PtrSafe Function lstrlenW Lib "kernel32" (ByVal lpString As LongPtr) As Long
+Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (iDestination As Any, iSource As Any, ByVal nLength As LongPtr)
+
+Public Enum TApplication
+  T_APP_UNDEF = 0
+  [_First] = 1
+  
+  T_APP_EXCEL = 1
+  T_APP_WORD = 2
+  T_APP_VISIO = 3
+  
+  [_Last] = 3
+End Enum
+
+Public Function OfficeCommandLine() As String
+  OfficeCommandLine = String$(lstrlenW(GetCommandLine()), 0)
+  Call CopyMemory(ByVal StrPtr(OfficeCommandLine), ByVal GetCommandLine(), LenB(OfficeCommandLine))
+End Function
+
+Public Function ActivateWindow(sClass$, Optional sWindow$ = vbNullString) As Boolean
+  On Error Resume Next
+  ActivateWindow = False
+  Dim nWindow&: nWindow = FindWindow(sClass, sWindow)
+  If nWindow <= 0 Then _
+    Exit Function
+  ActivateWindow = ActivateWindowHwnd(nWindow)
+End Function
+
+Public Function ActivateWindowHwnd(nWindow&) As Boolean
+  On Error Resume Next
+  ActivateWindowHwnd = False
+  If nWindow <= 0 Then _
+    Exit Function
+  If BringWindowToTop(nWindow) = 0 Then _
+    Exit Function
+  
+  Call SetFocus(nWindow)
+  ActivateWindowHwnd = True
+End Function
+
+Public Function ApplicationFromExtension(sExtension$) As TApplication
+  ApplicationFromExtension = T_APP_UNDEF
+  Select Case VBA.UCase(sExtension)
+  Case "XLS": ApplicationFromExtension = T_APP_EXCEL
+  Case "XLSX": ApplicationFromExtension = T_APP_EXCEL
+  Case "XLSM": ApplicationFromExtension = T_APP_EXCEL
+  Case "XLTM": ApplicationFromExtension = T_APP_EXCEL
+  Case "RTF": ApplicationFromExtension = T_APP_WORD
+  Case "DOC": ApplicationFromExtension = T_APP_WORD
+  Case "DOCX": ApplicationFromExtension = T_APP_WORD
+  Case "DOCM": ApplicationFromExtension = T_APP_WORD
+  Case "DOTM": ApplicationFromExtension = T_APP_WORD
+  Case "VSDX": ApplicationFromExtension = T_APP_VISIO
+  Case "VSDM": ApplicationFromExtension = T_APP_VISIO
+  Case "VSTX": ApplicationFromExtension = T_APP_VISIO
+  Case "VSTM": ApplicationFromExtension = T_APP_VISIO
+  End Select
+End Function
+
+Public Function ApplicationTypeFor(iApp As Object) As TApplication
+  ApplicationTypeFor = T_APP_UNDEF
+  Select Case iApp.Name
+  Case "Microsoft Excel": ApplicationTypeFor = T_APP_EXCEL
+  Case "Microsoft Word": ApplicationTypeFor = T_APP_WORD
+  Case "Microsoft Visio": ApplicationTypeFor = T_APP_VISIO
+  End Select
+End Function
+
+Public Function ApplicationWrapper(iType As TApplication) As Object
+  Dim iApplication As Object: Set iApplication = Application
+  If Application.Name = "Microsoft Visio" Then _
+    Call Err.Raise(vbObjectError, Description:="Visio does not support meta wrappers")
+  Select Case iType
+  Case T_APP_EXCEL: Set ApplicationWrapper = iApplication.Run("CreateWrapperXL")
+  Case T_APP_WORD: Set ApplicationWrapper = iApplication.Run("CreateWrapperWord")
+  Case T_APP_VISIO: Set ApplicationWrapper = iApplication.Run("CreateWrapperVisio")
+  End Select
+End Function
+
+' To use application wrapper copy required CreateWrapper functions to Main module and uncomment them
+'Public Function CreateWrapperXL() As API_XLWrapper
+'  Set CreateWrapperXL = New API_XLWrapper
+'End Function
+'
+'Public Function CreateWrapperWord() As API_WordWrapper
+'  Set CreateWrapperWord = New API_WordWrapper
+'End Function
+'
+'Public Function CreateWrapperVisio() As API_VisioWrapper
+'  Set CreateWrapperVisio = New API_VisioWrapper
+'End Function
+
+' Wrapper for active document
+Public Function OfficeActiveWrapper() As Object
+  Dim activeApp As Object: Set activeApp = Application
+  Dim iWrapper As Object
+  
+  Select Case ApplicationTypeFor(Application)
+  Case T_APP_EXCEL
+    Set iWrapper = ApplicationWrapper(T_APP_EXCEL)
+    Call iWrapper.SetDocument(activeApp.ActiveWorkbook)
+    
+  Case T_APP_WORD
+    Set iWrapper = ApplicationWrapper(T_APP_WORD)
+    Call iWrapper.SetDocument(activeApp.ActiveDocument)
+    
+  Case T_APP_VISIO
+    Set iWrapper = ApplicationWrapper(T_APP_VISIO)
+    Call iWrapper.SetDocument(activeApp.ActiveDocument)
+  End Select
+  
+  Set OfficeActiveWrapper = iWrapper
+End Function
+
+' Wrapper for this document
+Public Function OfficeThisWrapper() As Object
+  Dim activeApp As Object: Set activeApp = Application
+  Dim iWrapper As Object
+  
+  Select Case ApplicationTypeFor(Application)
+  Case T_APP_EXCEL
+    Set iWrapper = ApplicationWrapper(T_APP_EXCEL)
+    Call iWrapper.SetDocument(activeApp.ThisWorkbook)
+    
+  Case T_APP_WORD
+    Set iWrapper = ApplicationWrapper(T_APP_WORD)
+    Call iWrapper.SetDocument(activeApp.ThisDocument)
+    
+  Case T_APP_VISIO
+    Set iWrapper = ApplicationWrapper(T_APP_VISIO)
+    Call iWrapper.SetDocument(activeApp.ThisDocument)
+  End Select
+  
+  Set OfficeThisWrapper = iWrapper
+End Function
+
+' Path to active document folder
+Public Function OfficeActivePath() As String
+  Dim activeApp As Object: Set activeApp = Application
+  Select Case ApplicationTypeFor(Application)
+  Case T_APP_EXCEL: OfficeActivePath = activeApp.ActiveWorkbook.Path
+  Case T_APP_WORD: OfficeActivePath = activeApp.ActiveDocument.Path
+  Case T_APP_VISIO: OfficeActivePath = activeApp.ActiveDocument.Path
+  End Select
+End Function
+
+' Path to this document folder
+Public Function OfficeThisPath() As String
+  Dim activeApp As Object: Set activeApp = Application
+  Select Case ApplicationTypeFor(Application)
+  Case T_APP_EXCEL: OfficeThisPath = activeApp.ThisWorkbook.Path
+  Case T_APP_WORD: OfficeThisPath = activeApp.ThisDocument.Path
+  Case T_APP_VISIO: OfficeThisPath = activeApp.ThisDocument.Path
+  End Select
+End Function
+
+Public Function AddToClipboard(sText$)
+  With CreateObject(DATAOBJECT_BINDING)
+    Call .SetText(sText)
+    .PutInClipboard
+  End With
+End Function
+ 
+Public Function RetrieveFromClipboard() As String
+  With CreateObject(DATAOBJECT_BINDING)
+    Call .GetFromClipboard
+    RetrieveFromClipboard = .GetText
+  End With
+End Function
+
+Public Function WindowsTempFolder() As String
+  WindowsTempFolder = Environ("TEMP")
+End Function
+ 
+Public Function EnsureFolderExists(sPath$, Optional ByRef fso As Scripting.FileSystemObject = Nothing)
+  If fso Is Nothing Then _
+    Set fso = New Scripting.FileSystemObject
+  If fso.FolderExists(sPath) Then _
+    Exit Function
+    
+  Dim sParent$: sParent = sPath
+  Do
+    If sParent = vbNullString Then _
+      Exit Function
+    If VBA.Right(sParent, 1) <> "\" Then _
+      Exit Do
+    sParent = VBA.Left(sParent, VBA.Len(sParent) - 1)
+  Loop
+  
+  Dim nDelim&: nDelim = VBA.InStrRev(sParent, "\")
+  If nDelim = 0 Then _
+    Exit Function
+  sParent = VBA.Left(sParent, nDelim - 1)
+  
+  Call EnsureFolderExists(sParent, fso)
+  Call fso.CreateFolder(sPath)
+End Function
+
+Public Function CreateTextFileUTF16(sFile$, Optional bOverwrite = False) As Boolean
+  CreateTextFileUTF16 = False
+  
+  Dim fso As New Scripting.FileSystemObject
+  If Not bOverwrite Then _
+    If fso.FileExists(sFile) Then _
+      Exit Function
+  
+  On Error GoTo EXIT_FALSE
+  Call fso.CreateTextFile(sFile, Overwrite:=bOverwrite, Unicode:=True).Close
+  On Error GoTo 0
+  
+  CreateTextFileUTF16 = True
+  Exit Function
+EXIT_FALSE:
+End Function
+
+Public Function AppendTextToFileUTF16(sFile$, sMsg$) As Boolean
+  Const UTF16_MODE = TristateTrue
+  AppendTextToFileUTF16 = False
+
+  Dim fso As New Scripting.FileSystemObject
+  If Not fso.FileExists(sFile) Then _
+    Exit Function
+  
+  On Error GoTo RETURN_FALSE
+  Dim fs As Scripting.TextStream
+  Set fs = fso.OpenTextFile(sFile, ForAppending, Format:=UTF16_MODE)
+  If fs Is Nothing Then _
+    Exit Function
+
+  Call fs.WriteLine(sMsg)
+  Call fs.Close
+  
+  AppendTextToFileUTF16 = True
+  Exit Function
+RETURN_FALSE:
+End Function
+
+Public Function ReadTextFromFileUTF16(sFile$, ByRef sResult$) As Boolean
+  Const UTF16_MODE = TristateTrue
+  ReadTextFromFileUTF16 = False
+
+  Dim fso As New Scripting.FileSystemObject
+  If Not fso.FileExists(sFile) Then _
+    Exit Function
+  
+  On Error GoTo RETURN_FALSE
+  Dim fs As Scripting.TextStream
+  Set fs = fso.OpenTextFile(sFile, ForReading, Format:=UTF16_MODE)
+  If fs Is Nothing Then _
+    Exit Function
+
+  sResult = fs.ReadAll
+  Call fs.Close
+  
+  ReadTextFromFileUTF16 = True
+  Exit Function
+RETURN_FALSE:
+End Function
+
+Public Function CopyFileOrFolder(sSource$, sDestination$, Optional ByRef fso As Scripting.FileSystemObject = Nothing) As Boolean
+  CopyFileOrFolder = False
+  
+  If fso Is Nothing Then _
+    Set fso = New Scripting.FileSystemObject
+  
+  Dim bIsFile As Boolean: bIsFile = fso.FileExists(sSource)
+  Dim bIsFolder As Boolean: bIsFolder = fso.FolderExists(sSource)
+  If Not bIsFile And Not bIsFolder Then _
+    Exit Function
+  
+  Call EnsureFolderExists(fso.GetParentFolderName(sDestination), fso)
+  On Error GoTo RETURN_FALSE
+  If bIsFile Then
+    Call fso.CopyFile(sSource, sDestination, OverWriteFiles:=True)
+  Else
+    Call fso.CopyFolder(sSource, sDestination, OverWriteFiles:=True)
+  End If
+  On Error GoTo 0
+    
+  CopyFileOrFolder = True
+RETURN_FALSE:
+End Function
+
+Public Function MoveFileOrFolder(sSource$, sDestination$, Optional fso As Scripting.FileSystemObject = Nothing) As Boolean
+  MoveFileOrFolder = False
+  If sSource = sDestination Then _
+    Exit Function
+  If Not CopyFileOrFolder(sSource, sDestination, fso) Then _
+    Exit Function
+  
+  On Error GoTo RETURN_FALSE
+  If fso.FileExists(sSource) Then _
+    Call fso.DeleteFile(sSource)
+  If fso.FolderExists(sSource) Then _
+    Call fso.DeleteFolder(sSource)
+  On Error GoTo 0
+  
+  MoveFileOrFolder = True
+  Exit Function
+  
+RETURN_FALSE:
+  MoveFileOrFolder = False
+End Function
+
+Public Function ListFilesIn(sTargetFolder$, Optional sMask$ = "*.*") As Collection
+  Dim fso As New Scripting.FileSystemObject
+  If Not fso.FolderExists(sTargetFolder) Then _
+    Exit Function
+  
+  Dim iFiles As New Collection
+  Dim cQueue As New Collection
+  Call cQueue.Add(fso.GetFolder(sTargetFolder))
+  
+  Dim aFolder As Scripting.Folder
+  Dim subFolder As Scripting.Folder
+  Dim aFile As Scripting.File
+  Do While cQueue.Count > 0
+    Set aFolder = cQueue(1)
+    Call cQueue.Remove(1)
+    
+    For Each subFolder In aFolder.SubFolders
+      Call cQueue.Add(subFolder)
+    Next subFolder
+    
+    For Each aFile In aFolder.files
+      If VBA.UCase(aFile.Name) Like VBA.UCase(sMask) Then _
+        Call iFiles.Add(aFile.Path)
+    Next aFile
+  Loop
+  
+  Set ListFilesIn = iFiles
+End Function
+
+Public Function ForEachFileRecursive(sTargetFolder$, oCallback As Object, sFuncName$)
+  Dim fso As New Scripting.FileSystemObject
+  If Not fso.FolderExists(sTargetFolder) Then _
+    Exit Function
+  
+  Dim cQueue As New Collection
+  Call cQueue.Add(fso.GetFolder(sTargetFolder))
+  
+  Dim aFolder As Scripting.Folder
+  Dim subFolder As Scripting.Folder
+  Dim aFile As Scripting.File
+  Do While cQueue.Count > 0
+    Set aFolder = cQueue(1)
+    Call cQueue.Remove(1)
+    
+    For Each subFolder In aFolder.SubFolders
+      Call cQueue.Add(subFolder)
+    Next subFolder
+    
+    For Each aFile In aFolder.files
+      Call CallByName(oCallback, sFuncName, VbMethod, aFile)
+    Next aFile
+  Loop
+End Function
+
+' Callback should return TRUE to continue recursive
+Public Function ForEachFolderRecursive(sTargetFolder$, oCallback As Object, sFuncName$)
+  Dim fso As New Scripting.FileSystemObject
+  If Not fso.FolderExists(sTargetFolder) Then _
+    Exit Function
+  
+  Dim cQueue As New Collection
+  Call cQueue.Add(fso.GetFolder(sTargetFolder))
+  
+  Dim aFolder As Scripting.Folder
+  Dim subFolder As Scripting.Folder
+  Dim aFile As Scripting.File
+  Do While cQueue.Count > 0
+    Set aFolder = cQueue(1)
+    Call cQueue.Remove(1)
+    
+    If CallByName(oCallback, sFuncName, VbMethod, aFolder) Then
+      For Each subFolder In aFolder.SubFolders
+        Call cQueue.Add(subFolder)
+      Next subFolder
+    End If
+  Loop
+End Function
+
+Public Function FileToMD5(sTargetFile$) As String
+  FileToMD5 = ComputeFileHash(sTargetFile, "MD5CryptoServiceProvider")
+End Function
+
+Public Function FileToSHA1(sTargetFile$) As String
+  FileToSHA1 = ComputeFileHash(sTargetFile, "SHA1CryptoServiceProvider")
+End Function
+
+Public Function UnzipFile(sTargetFile$, sDestinationFolder$) As Boolean
+  Const OPT_DISABLE_DIALOGS = 4
+  Const OPT_YES_TO_ALL = 16
+  
+  UnzipFile = False
+  
+  Dim fso As New Scripting.FileSystemObject
+  If Not fso.FileExists(sTargetFile) Then _
+    Exit Function
+  
+  Dim sExt$: sExt = fso.GetExtensionName(sTargetFile)
+  Dim sZip$: sZip = sTargetFile
+  If sExt <> "zip" Then
+    sZip = Left(sTargetFile, Len(sTargetFile) - Len(sExt) - 1) & ".tmp.zip"
+    Call fso.GetFile(sTargetFile).Copy(sZip)
+  End If
+  
+  Call EnsureFolderExists(sDestinationFolder, fso)
+  
+  Dim aShell As New Shell32.Shell
+  Call aShell.Namespace(sDestinationFolder).CopyHere(aShell.Namespace(sZip).Items, OPT_DISABLE_DIALOGS + OPT_YES_TO_ALL)
+  
+  If sExt <> "zip" Then _
+    Call fso.DeleteFile(sZip)
+  
+  UnzipFile = True
+End Function
+
+Public Function ZipFolder(sTargetFolder$, sDestinationFile$) As Boolean
+  ZipFolder = False
+  
+  Dim fso As New Scripting.FileSystemObject
+  If Not fso.FolderExists(sTargetFolder) Then _
+    Exit Function
+  
+  Dim sZip$: sZip = sDestinationFile
+  Dim sExt$: sExt = fso.GetExtensionName(sDestinationFile)
+  If sExt <> "zip" Then _
+    sZip = Left(sDestinationFile, Len(sDestinationFile) - Len(sExt) - 1) & ".zip"
+  
+  Call CreateEmptyZip(sZip)
+  Dim aShell As New Shell32.Shell
+  Call aShell.Namespace(sZip).CopyHere(aShell.Namespace(sTargetFolder).Items)
+
+' Wait for zipping to finish
+  On Error Resume Next
+  Dim nTimeout&: nTimeout = 90 ' seconds
+  Do Until aShell.Namespace(sZip).Items.Count = aShell.Namespace(sTargetFolder).Items.Count
+    Call Sleep(1000)
+    nTimeout = nTimeout - 1
+    If nTimeout = 0 Then _
+      Exit Function
+  Loop
+  On Error GoTo 0
+  
+  If sExt <> "zip" Then
+    Call fso.CopyFile(sZip, sDestinationFile)
+    Call fso.DeleteFile(sZip)
+  End If
+
+  ZipFolder = True
+End Function
+
+Public Function PositionInMiddle(targetForm As Object)
+  Dim nTopOffset&: nTopOffset = (Application.UsableHeight / 2) - (targetForm.Height / 2)
+  Dim nLeftOffset&: nLeftOffset = (Application.UsableWidth / 2) - (targetForm.Width / 2)
+  
+  targetForm.StartUpPosition = 0
+  targetForm.Top = Application.Top + IIf(nTopOffset > 0, nTopOffset, 0)
+  targetForm.Left = Application.Left + IIf(nLeftOffset > 0, nLeftOffset, 0)
+End Function
+
+' ========
+Private Function CreateEmptyZip(sTarget$)
+  Dim nFileID%: nFileID = FreeFile
+  Open sTarget For Output As #nFileID
+  Print #nFileID, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
+  Close #nFileID
+End Function
+
+Private Function ComputeFileHash(sTargetFile$, sCryptoProvider$) As String
+  Dim fso As New Scripting.FileSystemObject
+  If Not fso.FileExists(sTargetFile) Then
+    ComputeFileHash = "File not exists"
+    Exit Function
+  End If
+    
+  Dim nFileID&: nFileID = VBA.FreeFile
+  On Error GoTo CANNOT_OPEN
+  Open sTargetFile For Binary Access Read As nFileID
+  On Error GoTo 0
+  
+  Dim iEncrypter As Object: Set iEncrypter = CreateObject("System.Security.Cryptography." & sCryptoProvider)
+  Dim iBuffer() As Byte
+  Dim nBlockSize&: nBlockSize = 2 ^ 16
+  Dim nFileSize&: nFileSize = VBA.LOF(nFileID)
+  If nFileSize < nBlockSize Then _
+    nBlockSize = ((nFileSize + 1024) \ 1024) * 1024
+  
+  ReDim iBuffer(0 To nBlockSize - 1)
+  Dim i&
+  For i = 1 To nFileSize \ nBlockSize Step 1
+    Get nFileID, , iBuffer
+    Call iEncrypter.TransformBlock(iBuffer, 0, nBlockSize, iBuffer, 0)
+  Next
+  
+  Get nFileID, , iBuffer
+  Call iEncrypter.TransformFinalBlock(iBuffer, 0, nFileSize Mod nBlockSize)
+  iBuffer = iEncrypter.Hash
+  
+  Close nFileID
+  Call iEncrypter.Clear
+  
+  Dim nPos&
+  Dim sHash$
+  For nPos = 1 To VBA.LenB(iBuffer)
+      sHash = sHash & VBA.LCase(VBA.Right("0" & VBA.Hex(VBA.AscB(VBA.MidB(iBuffer, nPos, 1))), 2))
+  Next nPos
+  
+  Set iEncrypter = Nothing
+  ComputeFileHash = sHash
+  Exit Function
+  
+CANNOT_OPEN:
+  ComputeFileHash = "Cannot open file"
+End Function

api/z_LoadPictureAPI.bas

@@ -0,0 +1,97 @@
+Attribute VB_Name = "z_LoadPictureAPI"
+'================ Ìîäóëü çàãðóçêè èçîáðàæåíèÿ ÷åðåç GDI =============
+' Shared module version: 20210228
+' Required reference:
+Option Private Module
+Option Explicit
+
+'Declare a UDT to store a GUID for the IPicture OLE Interface
+Private Type GUID
+  Data1 As Long
+  Data2 As Integer
+  Data3 As Integer
+  Data4(0 To 7) As Byte
+End Type
+
+'Declare a UDT to store the bitmap information
+Private Type PictDescriptor
+  size_ As LongLong
+  type_ As LongLong
+  hPic_ As LongPtr
+  hPal_ As LongLong
+End Type
+
+'Declare a UDT to store the GDI+ Startup information
+Private Type GdiplusStartupInput
+  version_ As Long
+  callback_ As LongPtr
+  suppBgThread_ As LongLong
+  suppExtCodecs_ As LongLong
+End Type
+
+'Windows API calls into the GDI+ library
+Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (pToken As LongPtr, pInputBuf As GdiplusStartupInput, Optional ByVal pOutputBuf As LongPtr = 0) As Long
+Private Declare PtrSafe Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal pFile As LongPtr, pBitmap As LongPtr) As Long
+Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal pBitmap As LongPtr, hbmReturn As LongPtr, ByVal pBackground As LongPtr) As Long
+Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" (ByVal pImage As LongPtr) As Long
+Private Declare PtrSafe Function GdiplusShutdown Lib "GDIPlus" (ByVal pToken As LongPtr) As Long
+Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As PictDescriptor, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, iPic As IPicture) As LongPtr
+
+Private Const PICTYPE_BITMAP = 1
+
+' Procedure:  LoadPictureGDI
+' Purpose:    Loads an image using GDI+
+' Returns:    The image as an IPicture Object
+Public Function LoadPictureGDI(ByVal sFileName$) As IPicture
+  'Initialize GDI+
+  Dim uGdiInput As GdiplusStartupInput
+  uGdiInput.version_ = 1
+  Dim hGdiPlus As LongPtr
+  Dim lResult&: lResult = GdiplusStartup(hGdiPlus, uGdiInput)
+
+  If lResult <> 0 Then _
+    Exit Function
+  
+  Dim hGdiImage As LongPtr
+  If GdipCreateBitmapFromFile(StrPtr(sFileName), hGdiImage) = 0 Then
+    Dim hBitmap As LongPtr
+    Call GdipCreateHBITMAPFromBitmap(hGdiImage, hBitmap, 0)
+    Set LoadPictureGDI = CreateIPicture(hBitmap)
+    Call GdipDisposeImage(hGdiImage)
+  End If
+  
+  Call GdiplusShutdown(hGdiPlus)
+End Function
+
+' Procedure:  CreateIPicture
+' Purpose:    Converts a image handle into an IPicture object.
+' Returns:    The IPicture object
+Private Function CreateIPicture(ByVal hPic As LongPtr) As IPicture
+  Dim IID_IDispatch As GUID
+  With IID_IDispatch
+    .Data1 = &H7BF80980
+    .Data2 = &HBF32
+    .Data3 = &H101A
+    .Data4(0) = &H8B
+    .Data4(1) = &HBB
+    .Data4(2) = &H0
+    .Data4(3) = &HAA
+    .Data4(4) = &H0
+    .Data4(5) = &H30
+    .Data4(6) = &HC
+    .Data4(7) = &HAB
+  End With
+  
+  Dim uPicInfo As PictDescriptor
+  With uPicInfo
+    .size_ = Len(uPicInfo)
+    .type_ = PICTYPE_BITMAP
+    .hPic_ = hPic
+    .hPal_ = 0
+  End With
+
+  Dim iPic As IPicture
+  Call OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, iPic)
+  Set CreateIPicture = iPic
+End Function
+

api/z_PastePictureAPI.bas

@@ -0,0 +1,156 @@
+Attribute VB_Name = "z_PastePictureAPI"
+'================ Ìîäóëü çàãðóçêè èçîáðàæåíèÿ ÷åðåç Copy/Paste =============
+' Shared module version: 20210228
+' Required reference: OLE Automation
+
+' PastePicture The entry point for the routine
+' CreatePicture Private function to convert a bitmap or metafile handle to an OLE reference
+' ErrorDescription Get the error text for an OLE error code
+Option Private Module
+Option Explicit
+Option Compare Text
+
+' Declare a UDT to store a GUID for the IPicture OLE Interface
+Private Type GUID
+  Data1 As Long
+  Data2 As Integer
+  Data3 As Integer
+  Data4(0 To 7) As Byte
+End Type
+
+' Declare a UDT to store the bitmap information
+Private Type PictDescriptor
+  size_ As LongLong
+  type_ As LongLong
+  hPic_ As LongPtr
+  hPal_ As LongLong
+End Type
+
+'Does the clipboard contain a bitmap/metafile?
+Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
+
+Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
+Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
+Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
+
+'Convert the handle into an OLE IPicture interface.
+Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" (pDesct As PictDescriptor, refID As GUID, ByVal nPicHandle As Long, iPic As IPicture) As Long
+
+'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
+Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
+
+'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
+Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal nHandle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
+
+'The API format types
+Private Const CF_BITMAP = 2
+Private Const CF_PALETTE = 9
+Private Const CF_ENHMETAFILE = 14
+Private Const IMAGE_BITMAP = 0
+Private Const LR_COPYRETURNORG = &H4
+
+Public Function PastePicture(Optional nType& = xlPicture) As IPicture
+  'Convert the type of picture requested from the xl constant to the API constant
+  Dim lPicType&: lPicType = IIf(nType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
+  
+  'Check if the clipboard contains the required format
+  Dim hPicAvail&: hPicAvail = IsClipboardFormatAvailable(lPicType)
+  If hPicAvail = 0 Then _
+    Exit Function
+  
+  Dim cbHandle&: cbHandle = OpenClipboard(0&)
+  If cbHandle <= 0 Then _
+    Exit Function
+ 
+  'Get a handle to the image data
+  Dim hPtr&: hPtr = GetClipboardData(lPicType)
+  
+  'Create our own copy of the image on the clipboard, in the appropriate format.
+  Dim hCopy&
+  If lPicType = CF_BITMAP Then
+    hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
+  Else
+    hCopy = CopyEnhMetaFile(hPtr, vbNullString)
+  End If
+  
+  'Release the clipboard to other programs
+  cbHandle = CloseClipboard
+  
+  'If we got a handle to the image, convert it into a Picture object and return it
+  If hPtr <> 0 Then _
+    Set PastePicture = CreatePicture(hCopy, 0, lPicType)
+End Function
+
+Private Function CreatePicture(ByVal hPic&, ByVal hPal&, ByVal lPicType) As IPicture
+  'OLE Picture types
+  Const PICTYPE_BITMAP = 1
+  Const PICTYPE_ENHMETAFILE = 4
+  
+  ' Create the Interface GUID (for the IPicture interface)
+  Dim IID_IDispatch As GUID
+  With IID_IDispatch
+    .Data1 = &H7BF80980
+    .Data2 = &HBF32
+    .Data3 = &H101A
+    .Data4(0) = &H8B
+    .Data4(1) = &HBB
+    .Data4(2) = &H0
+    .Data4(3) = &HAA
+    .Data4(4) = &H0
+    .Data4(5) = &H30
+    .Data4(6) = &HC
+    .Data4(7) = &HAB
+  End With
+  
+  ' Fill uPicInfo with necessary parts.
+  Dim uPicInfo As PictDescriptor
+  With uPicInfo
+    .size_ = Len(uPicInfo) ' Length of structure.
+    .type_ = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE) ' Type of Picture
+    .hPic_ = hPic ' Handle to image.
+    .hPal_ = IIf(lPicType = CF_BITMAP, hPal, 0) ' Handle to palette (if bitmap).
+  End With
+  
+  ' Create the Picture object.
+  Dim r&
+  Dim iPic As IPicture
+  r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, iPic)
+  
+  ' If an error occured, show the description
+  If r <> 0 Then _
+    Debug.Print "Create Picture: " & ErrorDescription(r)
+  
+  ' Return the new Picture object.
+  Set CreatePicture = iPic
+End Function
+
+
+Private Function ErrorDescription(nErr&) As String
+'OLECreatePictureIndirect return values
+  Const E_ABORT = &H80004004
+  Const E_ACCESSDENIED = &H80070005
+  Const E_FAIL = &H80004005
+  Const E_HANDLE = &H80070006
+  Const E_INVALIDARG = &H80070057
+  Const E_NOINTERFACE = &H80004002
+  Const E_NOTIMPL = &H80004001
+  Const E_OUTOFMEMORY = &H8007000E
+  Const E_POINTER = &H80004003
+  Const E_UNEXPECTED = &H8000FFFF
+  Const S_OK = &H0
+  
+  Select Case nErr
+    Case E_ABORT: ErrorDescription = " Aborted"
+    Case E_ACCESSDENIED: ErrorDescription = " Access Denied"
+    Case E_FAIL: ErrorDescription = " General Failure"
+    Case E_HANDLE: ErrorDescription = " Bad/Missing Handle"
+    Case E_INVALIDARG: ErrorDescription = " Invalid Argument"
+    Case E_NOINTERFACE: ErrorDescription = " No Interface"
+    Case E_NOTIMPL:  ErrorDescription = " Not Implemented"
+    Case E_OUTOFMEMORY: ErrorDescription = " Out of Memory"
+    Case E_POINTER:  ErrorDescription = " Invalid Pointer"
+    Case E_UNEXPECTED:  ErrorDescription = " Unknown Error"
+    Case S_OK: ErrorDescription = " Success!"
+  End Select
+End Function
+

dev/API_Logger.cls

@@ -0,0 +1,96 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_Logger"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ================ Log functionality =============
+' Shared module version: 20210413
+' Tested in: TestCommons
+' Depends on: ex_VBA
+' Required reference: Scripting
+' Note: log is saved as UTF-16 encoded text file
+Option Explicit
+
+Private fileName_ As String
+
+Public Function Init(sName$)
+  If sName = vbNullString Then _
+    Exit Function
+  fileName_ = sName
+  Call EnsureOutputExists
+End Function
+
+Public Property Get LogFileName() As String
+  LogFileName = fileName_
+End Property
+
+Public Function Log(sMsg$)
+  If fileName_ <> vbNullString Then
+    Call LogIntoFile(StampTime(sMsg))
+  Else
+    Call LogDefault(StampTime(sMsg))
+  End If
+End Function
+
+Public Function Report(sMsg$, Optional nFlags& = 0)
+  ' TODO: indicate flags
+  Call Log(sMsg)
+End Function
+
+Public Function Clear()
+  If fileName_ <> vbNullString Then _
+    Call CreateLogFile
+End Function
+
+' ==========
+Private Function LogIntoFile(sMsg$)
+  Const UTF16_MODE = TristateTrue
+  
+  Dim fso As New Scripting.FileSystemObject
+  If Not fso.FileExists(fileName_) Then _
+    GoTo CANNOT_ACCESS
+    
+  Dim fs As Scripting.TextStream: Set fs = fso.OpenTextFile(fileName_, ForAppending, Format:=UTF16_MODE)
+  If fs Is Nothing Then _
+    GoTo CANNOT_ACCESS
+  
+  Call fs.WriteLine(sMsg)
+  Call fs.Close
+  Exit Function
+  
+CANNOT_ACCESS:
+  Call LogDefault(StampTime("Cannot access log"))
+  Call LogDefault(sMsg)
+End Function
+
+Private Function LogDefault(sMsg$)
+  Debug.Print sMsg
+End Function
+
+Private Function EnsureOutputExists()
+  Dim fso As New Scripting.FileSystemObject
+  If fso.FileExists(fileName_) Then _
+    Exit Function
+    
+  Call CreateLogFile
+End Function
+
+Private Function StampTime(sMsg$) As String
+  StampTime = Format(Now(), "yyyy-mm-dd hh:mm:ss") & ": " & sMsg
+End Function
+
+Private Function CreateLogFile()
+  Dim fso As New Scripting.FileSystemObject
+  Call EnsureFolderExists(fso.GetParentFolderName(fileName_))
+  Dim fs As Scripting.TextStream: Set fs = fso.CreateTextFile(fileName_, Unicode:=True)
+  If fs Is Nothing Then
+    Call LogDefault(StampTime("Cannot create log: " & fileName_))
+  Else
+    Call fs.Close
+    Call Log("Log file created")
+  End If
+End Function

dev/API_MockInteraction.cls

@@ -0,0 +1,247 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_MockInteraction"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+'================ Mock âçàèìîäåéñòâèÿ ñ ïîëüçîâàòåëåì =========================
+' Shared module version: 20210331
+' Depends on: DevTester, API_UserInteraction
+' Required reference:
+Option Explicit
+Implements API_UserInteraction
+
+Private Enum InteractionType
+  T_UI_INVALID = 0
+  T_UI_MESSAGE
+  T_UI_QUESTION
+  T_UI_PROMPT_INPUT
+  T_UI_PROMPT_FILE
+  T_UI_FOLLOW_HYPERLINK
+End Enum
+
+Private Type ExpectationInfo
+  type_ As InteractionType
+  id_ As Long
+  response_ As String
+End Type
+
+Private types_ As Collection ' of InteractionType
+Private ids_ As Collection ' of Long
+Private responses_ As Collection ' of String
+
+Private Sub Class_Initialize()
+  Call ResetCollection
+End Sub
+
+Public Function ExpectNoInteraction()
+  Call ResetExpectations
+End Function
+
+Public Function ExpectMessage(nMsg&)
+  Call AddExpectation(T_UI_MESSAGE, nMsg)
+End Function
+
+Public Function ExpectQuestion(nMsg&, bAnswerYes As Boolean)
+  Call AddExpectation(T_UI_QUESTION, nMsg, IIf(bAnswerYes, "YES", "NO"))
+End Function
+
+Public Function ExpectInputPrompt(sResponse$)
+  Call AddExpectation(T_UI_PROMPT_INPUT, sResponse:=sResponse)
+End Function
+
+Public Function ExpectFilePrompt(sResponse$)
+  Call AddExpectation(T_UI_PROMPT_FILE, sResponse:=sResponse)
+End Function
+
+Public Function ExpectFollowHyperlink(sLink$)
+  Call AddExpectation(T_UI_FOLLOW_HYPERLINK, sResponse:=sLink)
+End Function
+
+Public Function ResetExpectations() As Boolean
+  ResetExpectations = ids_.Count = 0
+  If ResetExpectations Then _
+    Exit Function
+    
+  Dim sMsg$: sMsg = "Unrealized expectations: "
+  Dim info As ExpectationInfo
+  Do While ids_.Count <> 0
+    sMsg = sMsg & vbNewLine & InfoToString(PopExpectation)
+  Loop
+  Call Dev_LogMsg(sMsg)
+End Function
+
+Public Function API_UserInteraction_ShowMessage(nMsg&, ParamArray params() As Variant)
+  Dim iExpected As ExpectationInfo: iExpected = PopExpectation
+  If iExpected.type_ = T_UI_INVALID Then _
+    Call Err.Raise(UNEXPECTED_INTERACTION, Description:="ShowMessage " & nMsg)
+    
+  Dim iActual As ExpectationInfo
+  iActual.type_ = T_UI_MESSAGE
+  iActual.id_ = nMsg
+  iActual.response_ = vbNullString
+  
+  If Not CompareInfo(iActual, iExpected) Then _
+    Call Dev_LogMsg(Fmt("Unrecognized interaction" & vbNewLine & _
+                        "Expected: {1}" & vbNewLine & _
+                        "Actual: {2}", _
+                        InfoToString(iExpected), InfoToString(iActual)))
+End Function
+
+Public Function API_UserInteraction_AskQuestion(nQuestion&, ParamArray params() As Variant) As Boolean
+  Dim iExpected As ExpectationInfo: iExpected = PopExpectation
+  If iExpected.type_ = T_UI_INVALID Then _
+    Call Err.Raise(UNEXPECTED_INTERACTION, Description:="AskQuestion " & nQuestion)
+    
+  Dim iActual As ExpectationInfo
+  iActual.type_ = T_UI_QUESTION
+  iActual.id_ = nQuestion
+  
+  If Not CompareInfo(iActual, iExpected) Then _
+    Call Dev_LogMsg(Fmt("Unrecognized interaction" & vbNewLine & _
+                        "Expected: {1}" & vbNewLine & _
+                        "Actual: {2}", _
+                        InfoToString(iExpected), InfoToString(iActual)))
+  API_UserInteraction_AskQuestion = iExpected.response_ = "YES"
+End Function
+
+Public Function API_UserInteraction_PromptInput( _
+                                  sPrompt$, _
+                                  Optional sTitle$ = vbNullString, _
+                                  Optional sInitial As Variant) As String
+  Dim iExpected As ExpectationInfo: iExpected = PopExpectation
+  If iExpected.type_ = T_UI_INVALID Then _
+    Call Err.Raise(UNEXPECTED_INTERACTION, Description:="PromptInput")
+    
+  Dim iActual As ExpectationInfo
+  iActual.type_ = T_UI_PROMPT_INPUT
+  
+  If Not CompareInfo(iActual, iExpected) Then _
+    Call Dev_LogMsg(Fmt("Unrecognized interaction" & vbNewLine & _
+                        "Expected: {1}" & vbNewLine & _
+                        "Actual: {2}", _
+                        InfoToString(iExpected), InfoToString(iActual)))
+  API_UserInteraction_PromptInput = iExpected.response_
+End Function
+
+Public Function API_UserInteraction_PromptFileFilter( _
+                                  sInitialPath$, sDescription$, sFilter$, _
+                                  Optional sTitle$ = "Âûáåðèòå ôàéë", _
+                                  Optional bNewApplication As Boolean = False) As String
+  Dim iExpected As ExpectationInfo: iExpected = PopExpectation
+  If iExpected.type_ = T_UI_INVALID Then _
+    Call Err.Raise(UNEXPECTED_INTERACTION, Description:="PromptFileFilter")
+    
+  Dim iActual As ExpectationInfo
+  iActual.type_ = T_UI_PROMPT_FILE
+  
+  If Not CompareInfo(iActual, iExpected) Then _
+    Call Dev_LogMsg(Fmt("Unrecognized interaction" & vbNewLine & _
+                        "Expected: {1}" & vbNewLine & _
+                        "Actual: {2}", _
+                        InfoToString(iExpected), InfoToString(iActual)))
+  API_UserInteraction_PromptFileFilter = iExpected.response_
+End Function
+
+Public Function API_UserInteraction_PromptFile(sInitialPath$, _
+                                  Optional sTitle$ = "Âûáåðèòå ôàéë", _
+                                  Optional cDescriptions As Collection = Nothing, _
+                                  Optional cFilters As Collection = Nothing, _
+                                  Optional bNewApplication As Boolean = False) As String
+  Dim iExpected As ExpectationInfo: iExpected = PopExpectation
+  If iExpected.type_ = T_UI_INVALID Then _
+    Call Err.Raise(UNEXPECTED_INTERACTION, Description:="PromptFile")
+    
+  Dim iActual As ExpectationInfo
+  iActual.type_ = T_UI_PROMPT_FILE
+  
+  If Not CompareInfo(iActual, iExpected) Then _
+    Call Dev_LogMsg(Fmt("Unrecognized interaction" & vbNewLine & _
+                        "Expected: {1}" & vbNewLine & _
+                        "Actual: {2}", _
+                        InfoToString(iExpected), InfoToString(iActual)))
+  API_UserInteraction_PromptFile = iExpected.response_
+End Function
+
+Public Function API_UserInteraction_PromptFolder(sInitialPath$, _
+                                  Optional sTitle$ = "Âûáåðèòå êàòàëîã", _
+                                  Optional bNewApplication As Boolean = False) As String
+  Dim iExpected As ExpectationInfo: iExpected = PopExpectation
+  If iExpected.type_ = T_UI_INVALID Then _
+    Call Err.Raise(UNEXPECTED_INTERACTION, Description:="PromptFile")
+    
+  Dim iActual As ExpectationInfo
+  iActual.type_ = T_UI_PROMPT_FILE
+  
+  If Not CompareInfo(iActual, iExpected) Then _
+    Call Dev_LogMsg(Fmt("Unrecognized interaction" & vbNewLine & _
+                        "Expected: {1}" & vbNewLine & _
+                        "Actual: {2}", _
+                        InfoToString(iExpected), InfoToString(iActual)))
+  API_UserInteraction_PromptFolder = iExpected.response_
+End Function
+
+Public Function API_UserInteraction_FollowHyperlink(oDocument As Object, sAddress$)
+  Dim iExpected As ExpectationInfo: iExpected = PopExpectation
+  If iExpected.type_ = T_UI_INVALID Then _
+    Call Err.Raise(UNEXPECTED_INTERACTION, Description:="FollowHyperlink")
+    
+  Dim iActual As ExpectationInfo
+  iActual.type_ = T_UI_FOLLOW_HYPERLINK
+  
+  If Not CompareInfo(iActual, iExpected) Then _
+    Call Dev_LogMsg(Fmt("Unrecognized interaction" & vbNewLine & _
+                        "Expected: {1}" & vbNewLine & _
+                        "Actual: {2}", _
+                        InfoToString(iExpected), InfoToString(iActual)))
+End Function
+
+' =====
+Private Function ResetCollection()
+  Set ids_ = New Collection
+  Set types_ = New Collection
+  Set responses_ = New Collection
+End Function
+
+Private Function AddExpectation(nType As InteractionType, Optional nID& = 0, Optional sResponse$ = vbNullString)
+  Call types_.Add(nType)
+  Call ids_.Add(nID)
+  Call responses_.Add(sResponse)
+End Function
+
+Private Function PopExpectation() As ExpectationInfo
+  If ids_.Count = 0 Then
+    PopExpectation.id_ = T_UI_INVALID
+    Exit Function
+  End If
+  
+  PopExpectation.id_ = ids_.Item(1)
+  PopExpectation.type_ = types_.Item(1)
+  PopExpectation.response_ = responses_.Item(1)
+  
+  Call ids_.Remove(1)
+  Call types_.Remove(1)
+  Call responses_.Remove(1)
+End Function
+
+Private Function InfoToString(target As ExpectationInfo) As String
+  Select Case target.type_
+    Case T_UI_MESSAGE: InfoToString = "Message " & target.id_
+    Case T_UI_QUESTION: InfoToString = "Question " & target.id_
+    Case T_UI_PROMPT_INPUT: InfoToString = "InputBox with response " & target.response_
+    Case T_UI_PROMPT_FILE: InfoToString = "FilePromp with response " & target.response_
+    Case T_UI_FOLLOW_HYPERLINK: InfoToString = "Follow hyperlink " & target.response_
+  End Select
+End Function
+
+Private Function CompareInfo(val1 As ExpectationInfo, val2 As ExpectationInfo) As Boolean
+  CompareInfo = False
+  If val1.id_ <> val2.id_ Then _
+    Exit Function
+  If val1.type_ <> val2.type_ Then _
+    Exit Function
+  CompareInfo = True
+End Function

dev/API_TestRunner.cls

@@ -0,0 +1,119 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_TestRunner"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+'================ VBA tests runner =============
+' Shared module version: 20220410
+' Depends on: DevTester, DevTools, DataTools, API_Logger, CDS_InfoTests, CDS_InfoFunction, API_Timer
+' Required reference: Scripting, VBIDE, Word, Excel, Visio
+Option Explicit
+
+Public testsDB_ As Scripting.Dictionary ' Value = Collection of tests
+Private target_ As Object ' Wrapper
+Private logger_ As API_Logger
+Private timer_ As API_Timer
+
+' Sink object should implement function PushTestResult(sSuite$, sTest$, bResult As Boolean, sMsg$, dDuration as Double)
+Private sink_ As Object
+
+Private Sub Class_Initialize()
+  Set timer_ = New API_Timer
+End Sub
+
+Private Sub Class_Terminate()
+  Set target_ = Nothing
+End Sub
+
+Public Function Init(targetWrapper As Object, oLog As API_Logger, Optional oSink As Object = Nothing)
+  Set target_ = targetWrapper
+  Set logger_ = oLog
+  Set sink_ = oSink
+  Set testsDB_ = New Scripting.Dictionary
+End Function
+
+Public Function ScanTests() As Boolean
+  On Error GoTo RETURN_FALSE
+  
+  Call logger_.Log("Scanning for tests...")
+  Dim nCount&: nCount = Dev_ScanTests(target_.Document.VBProject, testsDB_)
+  ScanTests = True
+  Call logger_.Log("Found tests: " & nCount)
+  Exit Function
+  
+RETURN_FALSE:
+  ScanTests = False
+  Call logger_.Log("Failed to scan tests. Error code " & Err.Number & ":" & Err.Description)
+End Function
+
+Public Function RunAllTests() As CDS_InfoTests
+  If Not ScanTests Then _
+    Exit Function
+
+  Dim iResult As New CDS_InfoTests
+  Dim sSuite As Variant
+  Dim tests As Collection
+  For Each sSuite In testsDB_
+    Set tests = testsDB_(sSuite)
+    Dim sTest As Variant
+    For Each sTest In tests
+      Call iResult.AddTest(RunTest(CStr(sSuite), CStr(sTest)))
+    Next sTest
+  Next sSuite
+
+  Set RunAllTests = iResult
+End Function
+
+Public Function RunTest(sSuite$, sTest$) As Boolean
+  RunTest = False
+  
+  Call timer_.Start
+  On Error GoTo CANNOT_RUN
+  Dim sMsg$: sMsg = RunInternal(sSuite, sTest)
+  On Error GoTo 0
+  
+  RunTest = sMsg = "OK"
+  If Not sink_ Is Nothing Then _
+    Call sink_.PushTestResult(sSuite, sTest, RunTest, sMsg, timer_.TimeElapsed)
+  Call logger_.Log(sSuite & "." & sTest & " ... " & sMsg)
+  
+  Exit Function
+CANNOT_RUN:
+  Call logger_.Log(sSuite & "." & sTest & " ... " & "Failed to run the test")
+End Function
+
+' =====
+Private Function RunInternal(sSuite$, sTest$) As String
+  If TypeOf target_.Application Is Visio.Application Then
+    RunInternal = RunFileIO(sSuite, sTest)
+  Else
+    RunInternal = target_.Run("DevTester.Dev_RunTest", sSuite, sTest)
+  End If
+End Function
+
+Private Function RunFileIO(sSuite$, sTest$) As String
+  Const UTF16_MODE = TristateTrue
+  
+  Dim sFileName$: sFileName = target_.Document.Name & "_IO.txt"
+  Dim sPath$: sPath = target_.Document.Path & sFileName
+
+  Dim fso As New Scripting.FileSystemObject
+  If fso.FileExists(sPath) Then _
+    Call fso.DeleteFile(sPath)
+  
+  Call target_.Run("Dev_RunTestFileIO", sSuite, sTest, sFileName)
+  
+  If Not fso.FileExists(sPath) Then
+    Call logger_.Log(sSuite & "." & sTest & " ... " & "Failed to run the test")
+    Exit Function
+  End If
+  
+  Dim fs As Scripting.TextStream: Set fs = fso.OpenTextFile(sPath, ForReading, Format:=UTF16_MODE)
+  RunFileIO = fs.ReadAll
+  Call fs.Close
+  Call fso.DeleteFile(sPath)
+End Function

dev/CDS_InfoFunction.cls

@@ -0,0 +1,16 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "CDS_InfoFunction"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+'============ Function info ============
+' Shared module version: 20210220
+Option Explicit
+
+Public name_ As String
+Public type_ As VBIDE.vbext_ProcKind
+Public isPublic_ As Boolean

dev/CDS_InfoTests.cls

@@ -0,0 +1,33 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "CDS_InfoTests"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+'================ Tests summary ============
+' Shared module version: 20210306
+Option Explicit
+
+Public count_ As Long
+Public success_ As Long
+Public failed_ As Long
+
+Public Function AddTest(bResult As Boolean)
+  count_ = count_ + 1
+  If bResult Then
+    success_ = success_ + 1
+  Else
+    failed_ = failed_ + 1
+  End If
+End Function
+
+Public Function MergeStats(iSource As CDS_InfoTests)
+  If iSource Is Nothing Then _
+    Exit Function
+  count_ = count_ + iSource.count_
+  success_ = success_ + iSource.success_
+  failed_ = failed_ + iSource.failed_
+End Function

dev/DevTester.bas

@@ -0,0 +1,679 @@
+Attribute VB_Name = "DevTester"
+'================ Developer Testing mechanics =============
+' Shared module version: 20220614
+' Depends on: ex_VBA
+' Required reference: Microsoft Scripting Runtime
+Option Private Module
+Option Explicit
+
+Private Const ENUM_PARAM_CLASS_MODULE = 2
+Private Const ENUM_PARAM_PROCEDURE = 0
+
+Public Enum TTestErrors
+  ASSERT_FAIL = vbObjectError + 1
+  UNEXPECTED_INTERACTION
+End Enum
+
+Private g_TestLog As String
+Private g_TestCase As String
+Private g_TestClause As String
+
+Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal nMilliseconds As LongPtr)
+
+' Run this procedure to add new test suite
+Public Sub RunAddTestSuite()
+  Dim iProject As Object: Set iProject = GetVBProject
+
+  Dim sName$: sName = InputBox("Input suite name s_Suite")
+  If sName = vbNullString Then _
+    Exit Sub
+  If Not sName Like "s_*" Then
+    Call MsgBox("Invalid suite name", vbExclamation)
+    Exit Sub
+  End If
+  
+  Dim aComponent As Object: Set aComponent = FindVBComponent(iProject, sName)
+  If Not aComponent Is Nothing Then
+    Call MsgBox("Test suite already exists", vbExclamation)
+    Exit Sub
+  End If
+  
+  Dim iNewComponent As Object
+  Set iNewComponent = iProject.VBComponents.Add(ENUM_PARAM_CLASS_MODULE)
+  iNewComponent.Name = sName
+  Call iNewComponent.CodeModule.AddFromString(DefaultTestCode)
+  
+  Dim iHelper As Object: Set iHelper = FindVBComponent(iProject, "DevHelper").CodeModule
+  Dim nStart&: nStart = iHelper.ProcStartLine("Dev_GetTestSuite", ENUM_PARAM_PROCEDURE)
+  Call iHelper.InsertLines(nStart + 3, GetTestSuiteLine(sName))
+End Sub
+
+Public Function Dev_LogMsg(sMsg$)
+  If g_TestLog <> vbNullString Then _
+    g_TestLog = g_TestLog & vbNewLine
+    
+  If g_TestCase <> vbNullString Then
+    g_TestLog = g_TestLog & "Test case: " & g_TestCase & vbNewLine
+    g_TestCase = vbNullString
+  End If
+  
+  If g_TestClause <> vbNullString Then
+    g_TestLog = g_TestLog & "Test clause: " & g_TestClause & vbNewLine
+    g_TestClause = vbNullString
+  End If
+  
+  g_TestLog = g_TestLog & sMsg
+End Function
+
+Public Function Dev_LogError(nErrID&, Optional sDescription$ = vbNullString)
+  Select Case nErrID
+    Case 0 To 512: Call Dev_LogMsg("System error " & nErrID & vbNewLine & sDescription)
+    Case ASSERT_FAIL: Call Dev_LogMsg("Assertion failed... Aborting test")
+    Case UNEXPECTED_INTERACTION: Call Dev_LogMsg("Unexpected user interaction ... Aborting test")
+    Case Else: Call Dev_LogMsg("Unknown error type " & nErrID & vbNewLine & sDescription)
+  End Select
+End Function
+
+Public Function Dev_RunTestFileIO(sSuite$, sTest$, sOutputFile$)
+  Const UTF16_MODE = TristateTrue
+  
+  Dim sResult$: sResult = Dev_RunTest(sSuite, sTest)
+  Dim sPath$: sPath = Application.ActiveDocument.Path & sOutputFile
+  
+  Dim fso As New Scripting.FileSystemObject
+  Dim fs As Scripting.TextStream: Set fs = fso.OpenTextFile(sPath, ForWriting, Create:=True, Format:=UTF16_MODE)
+  
+  Call fs.Write(sResult)
+  Call fs.Close
+End Function
+
+Public Function Dev_RunTest(sSuite$, sTest$) As String
+  Dim iSuite As Object: Set iSuite = Dev_GetTestSuite(sSuite)
+  If iSuite Is Nothing Then
+    Dev_RunTest = "Invalid test suite"
+    Exit Function
+  End If
+  
+  Call Randomize
+  Call ResetLog
+  Call ResetDescription
+  
+  On Error GoTo ON_ERROR
+  Call iSuite.Setup
+  Call CallByName(iSuite, sTest, VbMethod)
+  Call iSuite.Teardown
+  On Error GoTo 0
+  
+  Dev_RunTest = IIf(g_TestLog = vbNullString, "OK", "FAILED" & vbNewLine & g_TestLog)
+  Exit Function
+  
+ON_ERROR:
+  Call Dev_LogError(Err.Number, Err.Description)
+  Dev_RunTest = "FAILED" & vbNewLine & g_TestLog
+  Set iSuite = Nothing
+End Function
+
+Public Function Dev_RunTestDebug(sSuite$, sTest$) As String
+  Dim iSuite As Object: Set iSuite = Dev_GetTestSuite(sSuite)
+  If iSuite Is Nothing Then
+    Dev_RunTestDebug = "Invalid test suite"
+    Exit Function
+  End If
+  
+  Call ResetLog
+  Call ResetDescription
+  
+  Call iSuite.Setup
+  Call CallByName(iSuite, sTest, VbMethod)
+  Call iSuite.Teardown
+  
+  Dev_RunTestDebug = IIf(g_TestLog = vbNullString, "OK", "FAILED" & vbNewLine & g_TestLog)
+End Function
+
+' ====== Tester functions ========
+Public Function Dev_NewCase(sDescription$)
+  Call ResetDescription
+  g_TestCase = sDescription
+End Function
+
+Public Function Dev_NewClause(sDescription$)
+  g_TestClause = sDescription
+End Function
+
+Public Function Dev_ExpectObjectValid(oVal As Object, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+  Dev_ExpectObjectValid = TestObjectValid(oVal)
+  If Not Dev_ExpectObjectValid Then _
+    Call Dev_LogMsg("Expected valid object")
+  Call ResetClause
+End Function
+
+Public Function Dev_ExpectObjectInvalid(oVal As Object, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+  Dev_ExpectObjectInvalid = Not TestObjectValid(oVal)
+  If Not Dev_ExpectObjectInvalid Then _
+    Call Dev_LogMsg("Expected invalid object")
+  Call ResetClause
+End Function
+
+Public Function Dev_ExpectNothing(oVal As Object, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+  Dev_ExpectNothing = oVal Is Nothing
+  If Not Dev_ExpectNothing Then _
+    Call Dev_LogMsg("Expected Nothing")
+  Call ResetClause
+End Function
+
+Public Function Dev_ExpectNotNothing(oVal As Object, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+  Dev_ExpectNotNothing = Not oVal Is Nothing
+  If Not Dev_ExpectNotNothing Then _
+    Call Dev_LogMsg("Expected not Nothing")
+  Call ResetClause
+End Function
+
+Public Function Dev_ExpectTrue(bVal As Boolean, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+  Dev_ExpectTrue = bVal = True
+  If Not Dev_ExpectTrue Then _
+    Call Dev_LogMsg("Expected TRUE statement")
+  Call ResetClause
+End Function
+
+Public Function Dev_ExpectFalse(bVal As Boolean, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+  Dev_ExpectFalse = bVal = False
+  If Not Dev_ExpectFalse Then _
+    Call Dev_LogMsg("Expected FALSE statement")
+  Call ResetClause
+End Function
+
+Public Function Dev_ExpectEQ(actualValue As Variant, expectedValue As Variant, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+    
+  On Error GoTo INCOMPARABLE
+  Dev_ExpectEQ = CompareDeep(expectedValue, actualValue) = 0
+  On Error GoTo 0
+  
+  If Not Dev_ExpectEQ Then _
+    Call Dev_LogMsg(Fmt("Actual: {1} | Expectedl: {2}", actualValue, expectedValue))
+  Call ResetClause
+  Exit Function
+  
+INCOMPARABLE:
+  Dev_ExpectEQ = False
+  Call Dev_LogMsg(Fmt("Invalid comparison: {1} == {2}", actualValue, expectedValue))
+End Function
+
+Public Function Dev_ExpectNE(val1 As Variant, val2 As Variant, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+    
+  On Error GoTo INCOMPARABLE
+  Dev_ExpectNE = CompareDeep(val1, val2) <> 0
+  On Error GoTo 0
+  
+  If Not Dev_ExpectNE Then _
+    Call Dev_LogMsg(Fmt("Unexpected equality: {1} == {2}", val1, val2))
+  Call ResetClause
+  Exit Function
+  
+INCOMPARABLE:
+  Dev_ExpectNE = False
+  Call Dev_LogMsg(Fmt("Invalid comparison: {1} <> {2}", val1, val2))
+End Function
+
+Public Function Dev_ExpectGR(val1 As Variant, val2 As Variant, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+    
+  On Error GoTo INCOMPARABLE
+  Dev_ExpectGR = CompareDeep(val1, val2) > 0
+  On Error GoTo 0
+  
+  If Not Dev_ExpectGR Then _
+    Call Dev_LogMsg(Fmt("Expected: {1} > {2}", val1, val2))
+  Call ResetClause
+  Exit Function
+  
+INCOMPARABLE:
+  Dev_ExpectGR = False
+  Call Dev_LogMsg(Fmt("Invalid comparison: {1} > {2}", val1, val2))
+End Function
+
+Public Function Dev_ExpectLS(val1 As Variant, val2 As Variant, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+    
+  On Error GoTo INCOMPARABLE
+  Dev_ExpectLS = CompareDeep(val1, val2) < 0
+  On Error GoTo 0
+  
+  If Not Dev_ExpectLS Then _
+    Call Dev_LogMsg(Fmt("Expected: {1} < {2}", val1, val2))
+  Call ResetClause
+  Exit Function
+  
+INCOMPARABLE:
+  Dev_ExpectLS = False
+  Call Dev_LogMsg(Fmt("Invalid comparison: {1} < {2}", val1, val2))
+End Function
+
+Public Function Dev_ExpectGE(val1 As Variant, val2 As Variant, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+    
+  On Error GoTo INCOMPARABLE
+  Dev_ExpectGE = CompareDeep(val1, val2) >= 0
+  On Error GoTo 0
+  
+  If Not Dev_ExpectGE Then _
+    Call Dev_LogMsg(Fmt("Expected: {1} >= {2}", val1, val2))
+  Call ResetClause
+  Exit Function
+  
+INCOMPARABLE:
+  Dev_ExpectGE = False
+  Call Dev_LogMsg(Fmt("Invalid comparison: {1} >= {2}", val1, val2))
+End Function
+
+Public Function Dev_ExpectLE(val1 As Variant, val2 As Variant, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+    
+  On Error GoTo INCOMPARABLE
+  Dev_ExpectLE = CompareDeep(val1, val2) <= 0
+  On Error GoTo 0
+  
+  If Not Dev_ExpectLE Then _
+    Call Dev_LogMsg(Fmt("Expected: {1} <= {2}", val1, val2))
+  Call ResetClause
+  Exit Function
+  
+INCOMPARABLE:
+  Dev_ExpectLE = False
+  Call Dev_LogMsg(Fmt("Invalid comparison: {1} <= {2}", val1, val2))
+End Function
+
+Public Function Dev_ExpectAEQ(actualValue As Variant, expectedValue As Variant, nPrecision&, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+    
+  On Error GoTo INCOMPARABLE
+  Dev_ExpectAEQ = CompareApproximate(actualValue, expectedValue, nPrecision) = 0
+  On Error GoTo 0
+  
+  If Not Dev_ExpectAEQ Then _
+    Call Dev_LogMsg(Fmt("Actual: {1} | Expectedl: {2} | Precision: {3}", actualValue, expectedValue, nPrecision))
+  Call ResetClause
+  Exit Function
+  
+INCOMPARABLE:
+  Dev_ExpectAEQ = False
+  Call Dev_LogMsg(Fmt("Invalid comparison: {1} == {2}, precision {3}", actualValue, expectedValue, nPrecision))
+End Function
+
+Public Function Dev_ExpectANE(val1 As Variant, val2 As Variant, nPrecision&, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+    
+  On Error GoTo INCOMPARABLE
+  Dev_ExpectANE = CompareApproximate(val1, val2, nPrecision) <> 0
+  On Error GoTo 0
+  
+  If Not Dev_ExpectANE Then _
+    Call Dev_LogMsg(Fmt("Unexpected equality: {1} == {2}, precision: {3}", val1, val2, nPrecision))
+  Call ResetClause
+  Exit Function
+  
+INCOMPARABLE:
+  Dev_ExpectANE = False
+  Call Dev_LogMsg(Fmt("Invalid comparison: {1} <> {2}, precision {3}", val1, val2, nPrecision))
+End Function
+
+Public Function Dev_ExpectAGR(val1 As Variant, val2 As Variant, nPrecision&, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+    
+  On Error GoTo INCOMPARABLE
+  Dev_ExpectAGR = CompareApproximate(val1, val2, nPrecision) > 0
+  On Error GoTo 0
+  
+  If Not Dev_ExpectAGR Then _
+    Call Dev_LogMsg(Fmt("Expected: {1} > {2}, precision {3}", val1, val2, nPrecision))
+  Call ResetClause
+  Exit Function
+  
+INCOMPARABLE:
+  Dev_ExpectAGR = False
+  Call Dev_LogMsg(Fmt("Invalid comparison: {1} > {2}, precision {3}", val1, val2, nPrecision))
+End Function
+
+Public Function Dev_ExpectALS(val1 As Variant, val2 As Variant, nPrecision&, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+    
+  On Error GoTo INCOMPARABLE
+  Dev_ExpectALS = CompareApproximate(val1, val2, nPrecision) < 0
+  On Error GoTo 0
+  
+  If Not Dev_ExpectALS Then _
+    Call Dev_LogMsg(Fmt("Expected: {1} < {2}, precision {3}", val1, val2, nPrecision))
+  Call ResetClause
+  Exit Function
+  
+INCOMPARABLE:
+  Dev_ExpectALS = False
+  Call Dev_LogMsg(Fmt("Invalid comparison: {1} < {2}, precision {3}", val1, val2, nPrecision))
+End Function
+
+Public Function Dev_ExpectAGE(val1 As Variant, val2 As Variant, nPrecision&, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+    
+  On Error GoTo INCOMPARABLE
+  Dev_ExpectAGE = CompareApproximate(val1, val2, nPrecision) >= 0
+  On Error GoTo 0
+  
+  If Not Dev_ExpectAGE Then _
+    Call Dev_LogMsg(Fmt("Expected: {1} >= {2}, precision {3}", val1, val2, nPrecision))
+  Call ResetClause
+  Exit Function
+  
+INCOMPARABLE:
+  Dev_ExpectAGE = False
+  Call Dev_LogMsg(Fmt("Invalid comparison: {1} >= {2}, precision {3}", val1, val2, nPrecision))
+End Function
+
+Public Function Dev_ExpectALE(val1 As Variant, val2 As Variant, nPrecision&, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+    
+  On Error GoTo INCOMPARABLE
+  Dev_ExpectALE = CompareApproximate(val1, val2, nPrecision) <= 0
+  On Error GoTo 0
+  
+  If Not Dev_ExpectALE Then _
+    Call Dev_LogMsg(Fmt("Expected: {1} <= {2}, precision {3}", val1, val2, nPrecision))
+  Call ResetClause
+  Exit Function
+  
+INCOMPARABLE:
+  Dev_ExpectALE = False
+  Call Dev_LogMsg(Fmt("Invalid comparison: {1} <= {2}, precision {3}", val1, val2, nPrecision))
+End Function
+
+' ========= String comparisons ===========
+Public Function Dev_ExpectLike(sValue$, sMask$, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+    
+  Dev_ExpectLike = sValue Like sMask
+  If Not Dev_ExpectLike Then _
+    Call Dev_LogMsg(Fmt("Expected: {1} Like {2}", sValue, sMask))
+  Call ResetClause
+End Function
+
+Public Function Dev_ExpectNotLike(sValue$, sMask$, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+    
+  Dev_ExpectNotLike = Not sValue Like sMask
+  If Not Dev_ExpectNotLike Then _
+    Call Dev_LogMsg(Fmt("Expected: {1} not Like {2}", sValue, sMask))
+  Call ResetClause
+End Function
+
+' ======= Error comparisons ===========
+Public Function Dev_ExpectAnyError(Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+  Dev_ExpectAnyError = Err.Number <> 0
+  If Not Dev_ExpectAnyError Then _
+    Call Dev_LogMsg("Expected any Error, but got nothing")
+  Call ResetClause
+End Function
+
+Public Function Dev_ExpectError(nError&, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+  
+  Dev_ExpectError = Err.Number = nError
+  If Err.Number = 0 Then
+    Call Dev_LogMsg(Fmt("Expected Error #{1}, but got no error", nError))
+  ElseIf Not Dev_ExpectError Then
+    Call Dev_LogMsg(Fmt("Expected Error #{1}, actual Error #{2}", nError, Err.Number))
+  End If
+  
+  Call Err.Clear
+  Call ResetClause
+End Function
+
+Public Function Dev_ExpectErrorMsg(sDesc$, Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+  
+  Dev_ExpectErrorMsg = Err.Description = sDesc
+  If Err.Number = 0 Then
+    Call Dev_LogMsg(Fmt("Expected Error, but got no error"))
+  ElseIf Not Dev_ExpectErrorMsg Then
+    Call Dev_LogMsg(Fmt("Expected error msg: #{1}" & vbNewLine & "Actual error message: #{2}", sDesc, Err.Description))
+  End If
+  
+  Call Err.Clear
+  Call ResetClause
+End Function
+
+Public Function Dev_ExpectNoError(Optional sClause$ = vbNullString) As Boolean
+  If sClause <> vbNullString Then _
+    Call Dev_NewClause(sClause)
+  
+  Dev_ExpectNoError = Err.Number = 0
+  If Not Dev_ExpectNoError Then _
+    Call Dev_LogMsg(Fmt("Expected no Error, but got Error #{1}", Err.Number))
+  
+  Call Err.Clear
+  Call ResetClause
+End Function
+
+' =========== Assertion proxies ==========
+Public Function Dev_AssertObjectValid(oVal As Object, Optional sClause$ = vbNullString)
+  If Not Dev_ExpectObjectValid(oVal, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertObjectInvalid(oVal As Object, Optional sClause$ = vbNullString)
+  If Not Dev_ExpectObjectInvalid(oVal, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertNothing(oVal As Object, Optional sClause$ = vbNullString)
+  If Not Dev_ExpectNothing(oVal, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertNotNothing(oVal As Object, Optional sClause$ = vbNullString)
+  If Not Dev_ExpectNotNothing(oVal, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertTrue(bVal As Boolean, Optional sClause$ = vbNullString)
+  If Not Dev_ExpectTrue(bVal, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertFalse(bVal As Boolean, Optional sClause$ = vbNullString)
+  If Not Dev_ExpectFalse(bVal, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertEQ(expectedValue As Variant, actualValue As Variant, Optional sClause$ = vbNullString)
+  If Not Dev_ExpectEQ(expectedValue, actualValue, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertNE(val1 As Variant, val2 As Variant, Optional sClause$ = vbNullString)
+  If Not Dev_ExpectNE(val1, val2, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertGR(val1 As Variant, val2 As Variant, Optional sClause$ = vbNullString)
+  If Not Dev_ExpectGR(val1, val2, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertLS(val1 As Variant, val2 As Variant, Optional sClause$ = vbNullString)
+  If Not Dev_ExpectLS(val1, val2, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertGE(val1 As Variant, val2 As Variant, Optional sClause$ = vbNullString)
+  If Not Dev_ExpectGE(val1, val2, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertLE(val1 As Variant, val2 As Variant, Optional sClause$ = vbNullString)
+  If Not Dev_ExpectLE(val1, val2, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertAEQ(expectedValue As Variant, actualValue As Variant, nPrecision&, Optional sClause$ = vbNullString)
+  If Not Dev_ExpectAEQ(expectedValue, actualValue, nPrecision, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertANE(val1 As Variant, val2 As Variant, nPrecision&, Optional sClause$ = vbNullString)
+  If Not Dev_ExpectANE(val1, val2, nPrecision, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertAGR(val1 As Variant, val2 As Variant, nPrecision&, Optional sClause$ = vbNullString)
+  If Not Dev_ExpectAGR(val1, val2, nPrecision, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertALS(val1 As Variant, val2 As Variant, nPrecision&, Optional sClause$ = vbNullString)
+  If Not Dev_ExpectALS(val1, val2, nPrecision, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertAGE(val1 As Variant, val2 As Variant, nPrecision&, Optional sClause$ = vbNullString)
+  If Not Dev_ExpectAGE(val1, val2, nPrecision, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertALE(val1 As Variant, val2 As Variant, nPrecision&, Optional sClause$ = vbNullString)
+  If Not Dev_ExpectALE(val1, val2, nPrecision, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertLike(sValue$, sMask$, Optional sClause$ = vbNullString) As Boolean
+  If Not Dev_ExpectLike(sValue, sMask, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertNotLike(sValue$, sMask$, Optional sClause$ = vbNullString) As Boolean
+  If Not Dev_ExpectNotLike(sValue, sMask, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertAnyError(Optional sClause$ = vbNullString)
+  If Not Dev_ExpectAnyError(sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertError(nError&, Optional sClause$ = vbNullString) As Boolean
+  If Not Dev_ExpectError(nError, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertErrorMsg(sDesc$, Optional sClause$ = vbNullString) As Boolean
+  If Not Dev_ExpectErrorMsg(sDesc, sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+Public Function Dev_AssertNoError(Optional sClause$ = vbNullString) As Boolean
+  If Not Dev_ExpectNoError(sClause) Then _
+    Call Err.Raise(ASSERT_FAIL)
+End Function
+
+' ========
+Private Function ResetLog()
+  g_TestLog = vbNullString
+End Function
+
+Private Function ResetDescription()
+  g_TestCase = vbNullString
+  g_TestClause = vbNullString
+End Function
+
+Private Function ResetClause()
+  g_TestClause = vbNullString
+End Function
+
+Private Function TestObjectValid(target As Object) As Boolean
+  Call Sleep(100)
+  
+  On Error Resume Next
+  Dim sName$: sName = target.Name
+  Select Case Err.Number
+    ' no error
+    Case 0: TestObjectValid = True
+    
+    ' object doesnt not support property
+    Case 438: TestObjectValid = True
+    
+    Case Else: TestObjectValid = False
+  End Select
+End Function
+
+Private Function GetVBProject() As Object
+  Dim iApplication As Object: Set iApplication = Application
+  If Application.Name = "Microsoft Excel" Then
+    Set GetVBProject = iApplication.ThisWorkbook.VBProject
+  Else
+    Set GetVBProject = iApplication.VBE.ActiveVBProject
+  End If
+End Function
+
+Private Function FindVBComponent(iProject As Object, sName$) As Object
+  Dim aComponent As Object
+  For Each aComponent In iProject.VBComponents
+    If aComponent.Name = sName Then
+      Set FindVBComponent = aComponent
+      Exit Function
+    End If
+  Next aComponent
+End Function
+
+Private Function DefaultTestCode() As String
+  DefaultTestCode = _
+    "Public Function Setup()" & vbNewLine & _
+    "  ' Mandatory setup function" & vbNewLine & _
+    "End Function" & vbNewLine & _
+    vbNewLine & _
+    "Public Function Teardown()" & vbNewLine & _
+    "  ' Mandatory teardown function" & vbNewLine & _
+    "End Function" & vbNewLine & _
+    vbNewLine & _
+    "Public Function t_Init()" & vbNewLine & _
+    "  On Error GoTo PROPAGATE_ERROR" & vbNewLine & _
+    vbNewLine & _
+    "  Exit Function" & vbNewLine & _
+    "PROPAGATE_ERROR:" & vbNewLine & _
+    "  Call Dev_LogError(Err.Number, Err.Description)" & vbNewLine & _
+    "End Function"
+End Function
+
+Private Function GetTestSuiteLine(sName$) As String
+  GetTestSuiteLine = _
+    "    Case " & """" & sName & """" & ": " & _
+    "Set Dev_GetTestSuite = New " & sName
+End Function

dev/DevTesterUI.bas

@@ -0,0 +1,21 @@
+Attribute VB_Name = "DevTesterUI"
+'================ Developer Testing mechanics for UI testing =============
+' Shared module version: 20210401
+' Depends on: API_MockInteraction, API_UserInteraction, z_UIMessages
+' Required reference:
+Option Private Module
+Option Explicit
+
+Private g_MockUI As API_MockInteraction
+
+Public Function Dev_MockUI() As API_MockInteraction
+  If g_MockUI Is Nothing Then _
+    Set g_MockUI = New API_MockInteraction
+  Call SetUserInteraction(g_MockUI)
+  Set Dev_MockUI = g_MockUI
+End Function
+
+Public Function Dev_ResetUI() As Boolean
+  Dev_ResetUI = g_MockUI.ResetExpectations
+  Call SetUserInteraction(New API_UserInteraction)
+End Function

dev/DevTools.bas

@@ -0,0 +1,194 @@
+Attribute VB_Name = "DevTools"
+'================ Developer Tools =============
+' Shared module version: 20220811
+' Depends on: ex_WinAPI
+' Required reference: Scripting, VBIDE
+Option Private Module
+Option Explicit
+
+Private Const TEST_SUITE_MASK = "s_*"
+Private Const TEST_NAME_MASK = "t_*"
+Private Const COMPILATION_DELAY As Long = 250 ' ms
+
+Public Function CompileVBProject(target As VBIDE.VBProject) As Boolean
+  Const CONTROL_ID_COMPILE = 578
+  Const MSGBOX_CLASS_ID As String = "#32770"
+  Const MSGBOX_NAME As String = "Microsoft Visual Basic for Applications"
+  Const WINDOW_MESSAGE_CLOSE As Long = &H10
+  
+  target.VBE.MainWindow.Visible = True
+  With target.VBComponents(1).CodeModule
+    Call .CodePane.Show
+    Call .InsertLines(1, "123")
+    Call .DeleteLines(1, 1)
+  End With
+  
+  Dim btnCompile As CommandBarControl: Set btnCompile = target.VBE.CommandBars.FindControl(ID:=CONTROL_ID_COMPILE)
+  If Not btnCompile.Enabled Then
+    CompileVBProject = False
+    Exit Function
+  End If
+  
+  Call btnCompile.Execute
+  
+  Call Sleep(COMPILATION_DELAY)
+  
+  Dim nHwnd&: nHwnd = FindWindow(MSGBOX_CLASS_ID, MSGBOX_NAME)
+  CompileVBProject = nHwnd = 0
+  If Not CompileVBProject Then _
+    Call PostMessage(nHwnd, WINDOW_MESSAGE_CLOSE, 0&, 0&)
+End Function
+
+Public Function UpdateVersionStamp(target As VBIDE.VBProject, sVersion$) As Boolean
+  UpdateVersionStamp = False
+  
+  On Error Resume Next
+  Dim iModule As VBComponent: Set iModule = target.VBComponents("Main")
+  If iModule Is Nothing Then _
+    Exit Function
+  
+  Dim iCode As CodeModule: Set iCode = iModule.CodeModule
+  
+  Dim nLineStart&: nLineStart = 1
+  Dim nLineEnd&: nLineEnd = iCode.CountOfLines
+  
+  Dim nColumnStart&: nColumnStart = 1
+  Dim nColumnEnd&: nColumnEnd = 255
+  
+  If Not iCode.Find("Public Const PRODUCT_VERSION", nLineStart, nColumnStart, nLineEnd, nColumnEnd) Then _
+    Exit Function
+  Call iCode.ReplaceLine(nLineEnd, "Public Const PRODUCT_VERSION = """ & sVersion & """")
+  
+  UpdateVersionStamp = True
+End Function
+
+Public Function PrepareSkeletonFor(target As Object)
+  On Error Resume Next
+  Call target.Application.Run("'" & target.Name & "'" & "!Dev_PrepareSkeleton")
+End Function
+
+Public Function ExtractProperties(sLines() As String, ByRef nCurrent&, ByRef oSink As Scripting.Dictionary)
+  ExtractProperties = False
+  
+  Do While nCurrent <= UBound(sLines, 1)
+    Dim sLine$: sLine = sLines(nCurrent)
+    nCurrent = nCurrent + 1
+    If sLine Like "%%*" Then _
+      Exit Do
+      
+    Dim nSeparator&: nSeparator = VBA.InStr(1, sLine, "=")
+    If nSeparator = 0 Then _
+      GoTo NEXT_LINE
+    If VBA.Left(sLine, 1) = "#" Then _
+      GoTo NEXT_LINE
+    
+    Dim sKey$: sKey = VBA.Trim(VBA.Left(sLine, nSeparator - 1))
+    Dim sValue$: sValue = VBA.Trim(Right(sLine, VBA.Len(sLine) - nSeparator))
+    If oSink.Exists(sKey) Then _
+      Exit Function
+    Call oSink.Add(sKey, sValue)
+NEXT_LINE:
+  Loop
+  
+  ExtractProperties = True
+End Function
+
+Public Function Dev_CountPublicAPI(target As VBIDE.CodeModule) As Long
+  Dim nLine&
+  For nLine = 1 To target.CountOfLines Step 1
+    If InStr(1, target.Lines(nLine, 1), "Public") <> 0 Then _
+      Dev_CountPublicAPI = Dev_CountPublicAPI + 1
+  Next nLine
+End Function
+
+Public Function Dev_ScanFunctions(target As VBIDE.CodeModule) As Collection ' of CDS_InfoFunction
+  Dim cResult As New Collection
+
+  Dim currentFunc As CDS_InfoFunction
+  Dim lastFunc As New CDS_InfoFunction
+  Dim nLine&
+  For nLine = 1 To target.CountOfLines Step 1
+    Set currentFunc = ExtractProcedure(target, nLine)
+    If lastFunc.name_ <> currentFunc.name_ And currentFunc.name_ <> vbNullString Then
+      currentFunc.isPublic_ = IsPublicFunc(target, currentFunc)
+      Call cResult.Add(currentFunc)
+    End If
+    Set lastFunc = currentFunc
+  Next nLine
+  
+  Set Dev_ScanFunctions = cResult
+End Function
+
+Public Function Dev_ScanTests(target As VBIDE.VBProject, ByRef cTestsDB As Scripting.Dictionary) As Long
+  Dim nCount&: nCount = 0
+  Dim aComponent As VBIDE.VBComponent
+  Dim iComponents As VBIDE.VBComponents: Set iComponents = target.VBComponents
+  Dim tests As Collection
+  For Each aComponent In iComponents
+    If aComponent.Type <> vbext_ct_ClassModule Then _
+      GoTo NEXT_COMPONENT
+    If Not aComponent.Name Like TEST_SUITE_MASK Then _
+      GoTo NEXT_COMPONENT
+
+    Set tests = New Collection
+    Dim funcs As Collection: Set funcs = Dev_ScanFunctions(aComponent.CodeModule)
+    Dim aFunc As CDS_InfoFunction
+    For Each aFunc In funcs
+      If aFunc.name_ Like TEST_NAME_MASK And aFunc.isPublic_ Then _
+        Call tests.Add(aFunc.name_)
+    Next aFunc
+
+    If tests.Count > 0 Then
+      Call cTestsDB.Add(aComponent.Name, tests)
+      nCount = nCount + tests.Count
+    End If
+NEXT_COMPONENT:
+  Next aComponent
+
+  Set iComponents = Nothing
+  Set aComponent = Nothing
+
+  Dev_ScanTests = nCount
+End Function
+
+Public Function Dev_RemoveDebugCode(target As VBIDE.VBProject)
+  Dim selectedComps As New Collection
+  Dim aComponent As VBIDE.VBComponent
+  For Each aComponent In target.VBComponents
+    If Dev_IsTestingModule(aComponent.Name) Then _
+      Call selectedComps.Add(aComponent)
+  Next aComponent
+  
+  For Each aComponent In selectedComps
+    Call target.VBComponents.Remove(aComponent)
+  Next aComponent
+End Function
+
+Public Function Dev_IsTestingModule(sName$) As Boolean
+  Dev_IsTestingModule = True
+  
+  If sName Like TEST_SUITE_MASK Then _
+    Exit Function
+  If sName Like "DevHelper*" Then _
+    Exit Function
+  If sName Like "DevTester*" Then _
+    Exit Function
+  If sName Like "DevTesterUI*" Then _
+    Exit Function
+  If sName Like "API_MockInteraction*" Then _
+    Exit Function
+  
+  Dev_IsTestingModule = False
+End Function
+
+' =====
+Private Function ExtractProcedure(target As VBIDE.CodeModule, nLine&) As CDS_InfoFunction
+  Set ExtractProcedure = New CDS_InfoFunction
+  ExtractProcedure.name_ = target.ProcOfLine(nLine, ExtractProcedure.type_)
+End Function
+
+Private Function IsPublicFunc(target As VBIDE.CodeModule, func As CDS_InfoFunction) As Boolean
+  Dim nStart&: nStart = target.ProcBodyLine(func.name_, func.type_)
+  Dim sTxt$: sTxt = target.Lines(nStart, 1)
+  IsPublicFunc = InStr(1, sTxt, "Private") = 0
+End Function

dev/ex_ConceptOrganization.bas

@@ -0,0 +1,84 @@
+Attribute VB_Name = "ex_ConceptOrganization"
+' ======== Concept organization specific functionality ============
+' Shared module version: 20221031
+' Tested in:
+' Depends on:
+' Required reference: Scripting
+Option Private Module
+Option Explicit
+
+Public Enum TProjectType
+  T_PRJ_LEAD_ACTIVE = 1
+  T_PRJ_LEAD_TENTATIVE = 2
+  T_PRJ_OUTCOME = 3
+  T_PRJ_INCOME = 4
+End Enum
+
+Public Enum TProjectCategory
+  T_PCAT_ERR = 0
+  T_PCAT_MISC = 1
+  T_PCAT_OUTCOME = 2
+  T_PCAT_INCOME = 3
+End Enum
+
+Public Const SERVER_PATH_INCOME = "\\fs1.concept.ru\projects\01 Income-ïðîåêòû"
+Public Const SERVER_PATH_OUTCOME = "\\fs1.concept.ru\projects\02 Outcome-ïðîåêòû"
+Public Const SERVER_PATH_LEAD_ACTIVE = "\\fs1.concept.ru\projects\03 Ïåðåãîâîðû Àêòèâíûå"
+Public Const SERVER_PATH_LEAD_TENTATIVE = "\\fs1.concept.ru\projects\03 1 Ïåðåãîâîðû âîçìîæíûå"
+
+Public Function CCListProjects(nType As TProjectType) As Scripting.Dictionary
+  Dim iProjects As New Scripting.Dictionary
+  Set CCListProjects = iProjects
+  
+  Dim sFolder$: sFolder = GetProjectsFolder(nType)
+  Dim fso As New Scripting.FileSystemObject
+  If Not fso.FolderExists(sFolder) Then _
+    Exit Function
+  
+  Dim iSubFolder As Scripting.Folder
+  For Each iSubFolder In fso.GetFolder(sFolder).SubFolders
+    If CCTestProjectName(iSubFolder.Name) Then _
+      Call iProjects.Add(iSubFolder.Name, ProjectTypeToCategory(nType))
+  Next iSubFolder
+End Function
+
+Public Function CCTestProjectName(sProject$) As Boolean
+  CCTestProjectName = sProject Like "####*"
+End Function
+
+Public Function CCCategoryToString(nType As TProjectCategory) As String
+  Select Case nType
+  Case T_PCAT_ERR: CCCategoryToString = "ERR"
+  Case T_PCAT_INCOME: CCCategoryToString = "I"
+  Case T_PCAT_OUTCOME: CCCategoryToString = "O"
+  Case T_PCAT_MISC: CCCategoryToString = "-"
+  End Select
+End Function
+
+Public Function CCStringToCategory(sType$) As TProjectCategory
+  Select Case sType
+  Case "I": CCStringToCategory = T_PCAT_INCOME
+  Case "O": CCStringToCategory = T_PCAT_OUTCOME
+  Case "-": CCStringToCategory = T_PCAT_MISC
+  Case Else: CCStringToCategory = T_PCAT_ERR
+  End Select
+End Function
+
+' ============
+Private Function GetProjectsFolder(nType As TProjectType) As String
+  Select Case nType
+  Case T_PRJ_INCOME: GetProjectsFolder = SERVER_PATH_INCOME
+  Case T_PRJ_OUTCOME: GetProjectsFolder = SERVER_PATH_OUTCOME
+  Case T_PRJ_LEAD_ACTIVE: GetProjectsFolder = SERVER_PATH_LEAD_ACTIVE
+  Case T_PRJ_LEAD_TENTATIVE: GetProjectsFolder = SERVER_PATH_LEAD_TENTATIVE
+  End Select
+End Function
+
+Private Function ProjectTypeToCategory(nType As TProjectCategory) As TProjectCategory
+  Select Case nType
+  Case T_PRJ_INCOME: ProjectTypeToCategory = T_PCAT_INCOME
+  Case T_PRJ_OUTCOME: ProjectTypeToCategory = T_PCAT_OUTCOME
+  Case T_PRJ_LEAD_ACTIVE: ProjectTypeToCategory = T_PCAT_OUTCOME
+  Case T_PRJ_LEAD_TENTATIVE: ProjectTypeToCategory = T_PCAT_OUTCOME
+  End Select
+End Function

excel/API_XLRecordsWrapper.cls

@@ -0,0 +1,49 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_XLRecordsWrapper"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ==== Îáîëî÷êà äëÿ ëèñòà Excel êàê èñòî÷íèêà çàïèñåé äàííûõ =========
+' Shared module version: 20210329
+' Depends on:
+' Required reference:
+' Prerequisites: first column should contain data with no empty cells
+Option Explicit
+
+Private data_ As Excel.Worksheet
+Private row_ As Long
+Private start_ As Long
+
+Public Function Init(ws As Excel.Worksheet, Optional nStart& = 2)
+  start_ = nStart
+  Set data_ = ws
+  Call MoveStart
+End Function
+
+Public Function MoveStart()
+  row_ = start_
+End Function
+
+Public Function IsDone() As Boolean
+  IsDone = data_.Cells(row_, 1) = vbNullString
+End Function
+
+Public Function MoveNext() As Boolean
+  MoveNext = Not IsDone
+  If MoveNext Then _
+    row_ = row_ + 1
+End Function
+
+Public Function MovePrev() As Boolean
+  MovePrev = row_ > start_
+  If MovePrev Then _
+    row_ = row_ - 1
+End Function
+
+Public Function Field(nColumn&) As Excel.Range
+  Set Field = data_.Cells(row_, nColumn)
+End Function

excel/ex_Excel.bas

@@ -0,0 +1,151 @@
+Attribute VB_Name = "ex_Excel"
+'================ Äîïîëíèòåëüíûé ôóíêöèîíàë Excel =============
+' Shared module version: 20220623
+' Tested in:
+' Depends on:
+' Required reference: Scripting
+Option Private Module
+Option Explicit
+
+Public Const XLUTIL_GRAPH_PADDING = 0.1
+Public Const XL_DEFAULT_FIRST_ROW = 2
+Public Const XL_INVALID_ROW = -1
+
+Private Const XL_INFINITY_THRESHOLD = 255
+
+Public Function XLFirstEmptyCell(iRange As Excel.Range) As Long
+  Dim nItem&: nItem = 1
+  Dim iCell As Excel.Range
+  For Each iCell In iRange
+    If iCell = vbNullString Then
+      XLFirstEmptyCell = nItem
+      Exit Function
+    End If
+    nItem = nItem + 1
+  Next iCell
+  
+  XLFirstEmptyCell = -1
+End Function
+
+Public Function XLGetCallerCell() As Excel.Range
+  On Error GoTo RETURN_NOTHING
+  If TypeName(Application.Caller) = "Range" Then
+    Set XLGetCallerCell = Application.Caller
+    Exit Function
+  End If
+  
+RETURN_NOTHING:
+  On Error GoTo 0
+  Set XLGetCallerCell = Nothing
+End Function
+
+Public Function XLWorksheetExists(sName$, iWhere As Excel.Workbook) As Boolean
+  On Error Resume Next
+  Dim iSheet As Excel.Worksheet
+  Set iSheet = iWhere.Sheets(sName)
+  On Error GoTo 0
+  XLWorksheetExists = Not iSheet Is Nothing
+End Function
+
+Public Function XLShowAllData(target As Excel.Worksheet, Optional bKeepRows As Boolean = False, Optional bKeepColumns As Boolean = False)
+  On Error Resume Next
+  Call target.ShowAllData
+  On Error GoTo 0
+  
+  If Not bKeepRows Then _
+    target.Rows.EntireRow.Hidden = False
+  If Not bKeepColumns Then _
+    target.Columns.EntireColumn.Hidden = False
+End Function
+
+Public Function XLUpdateHyperlink(iCellAnchor As Excel.Range, sAddress$, Optional sSubAddress$ = "")
+  Call iCellAnchor.Hyperlinks.Delete
+  If sAddress = vbNullString Then _
+    Exit Function
+  Call iCellAnchor.Hyperlinks.Add(iCellAnchor, sAddress, sSubAddress)
+End Function
+
+Public Function AutoScaleGraphAxis(target As Excel.Chart, tValueRange As Excel.Range)
+  Dim dMinValue As Double: dMinValue = WorksheetFunction.Min(tValueRange)
+  Dim dMaxValue As Double: dMaxValue = WorksheetFunction.Max(tValueRange)
+  If dMaxValue = dMinValue Then _
+    Exit Function
+  
+  Dim dPrecision&: dPrecision = -(CLng(VBA.Log(dMaxValue - dMinValue) / VBA.Log(10#)) - 1)
+  
+  If VBA.Sgn(dMinValue) = VBA.Sgn(dMaxValue) Then
+    dMinValue = dMinValue * IIf(dMinValue > 0, 1 - XLUTIL_GRAPH_PADDING, 1 + XLUTIL_GRAPH_PADDING)
+    dMaxValue = dMaxValue * IIf(dMaxValue > 0, 1 + XLUTIL_GRAPH_PADDING, 1 - XLUTIL_GRAPH_PADDING)
+    dMinValue = WorksheetFunction.Round(dMinValue, dPrecision)
+    dMaxValue = WorksheetFunction.Round(dMaxValue, dPrecision)
+  
+    target.Axes(xlValue, xlPrimary).MinimumScale = dMinValue
+    target.Axes(xlValue, xlPrimary).MaximumScale = dMaxValue
+  End If
+  
+  If dPrecision > 0 Then
+    target.Axes(xlValue, xlPrimary).TickLabels.NumberFormat = "# ##0," & VBA.Replace(VBA.Space(dPrecision), " ", "0")
+  Else
+    target.Axes(xlValue, xlPrimary).TickLabels.NumberFormat = "# ##0"
+  End If
+End Function
+
+Public Function XLFindOrCreateID(sID$, nIdColumn&, target As Excel.Worksheet, _
+                                  Optional nFirstRow& = XL_DEFAULT_FIRST_ROW) As Long
+  ' Note: this function is precise but slow. Consider using Range.Find but beware of filtered cells being ignored
+  Dim nRow&: nRow = nFirstRow
+  Dim sTxt$
+  Do
+    sTxt = target.Cells(nRow, nIdColumn)
+    If sTxt = vbNullString Then _
+      Exit Do
+    If sTxt = sID Then
+      XLFindOrCreateID = nRow
+      Exit Function
+    End If
+    nRow = nRow + 1
+  Loop
+  target.Cells(nRow, nIdColumn) = sID
+  XLFindOrCreateID = nRow
+End Function
+
+Public Function XLBruteFindRow(sTarget$, nIdColumn&, wsWhere As Excel.Worksheet, _
+                          Optional nFirstRow = XL_DEFAULT_FIRST_ROW) As Long
+  XLBruteFindRow = XL_INVALID_ROW
+  Dim nRow&: nRow = nFirstRow
+  Dim sTxt$
+  Do
+    sTxt = wsWhere.Cells(nRow, nIdColumn)
+    If sTxt = vbNullString Then
+      Exit Function
+    ElseIf sTxt = sTarget Then
+      XLBruteFindRow = nRow
+      Exit Function
+    End If
+    nRow = nRow + 1
+  Loop
+End Function
+
+Public Function FlipColumnsOrder(target As Excel.Worksheet, nStart&, nFinish&)
+  Dim nItem&
+  For nItem = 0 To nFinish - nStart - 1 Step 1
+    Call target.Columns(nStart).Cut
+    Call target.Columns(nFinish - nItem + 1).Insert
+  Next nItem
+End Function
+
+Public Function XLForEachNonEmptyCell(target As Excel.Range, oCallback As Object, sFuncName$)
+  Dim aCell As Excel.Range
+  Dim blankCount%: blankCount = 0
+  For Each aCell In target
+    If aCell = vbNullString Then
+      blankCount = blankCount + 1
+      If blankCount > XL_INFINITY_THRESHOLD Then _
+        Exit Function
+    Else
+      blankCount = 0
+      Call CallByName(oCallback, sFuncName, VbMethod, aCell)
+    End If
+  Next aCell
+End Function
+

parsers/DetectorClassifier.cls

@@ -0,0 +1,50 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "DetectorClassifier"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ====== Classification entity detector =======
+' Shared module version: 20220615
+' Tested in:
+' Depends on:
+' Required reference: API_Python, ex_Python
+Option Explicit
+
+Private tags_ As String
+
+Public Function Init(sTags$)
+  tags_ = sTags
+End Function
+
+Public Function Test(sText$) As Boolean
+  If tags_ = vbNullString Then _
+    Exit Function
+  Test = AccessPython.CallFunction(PY_MODULE_TEXT, "extract_entities", Array(sText)) <> Array()
+End Function
+
+Public Function ExtractFragments(sText$) As PC_ParsedData
+  Dim iData As New PC_ParsedData
+  
+  On Error GoTo SKIP_PYTHON
+  Dim iResult As Variant
+  iResult = AccessPython.CallFunction(PY_MODULE_TEXT, "extract_entities", Array(sText))
+  On Error GoTo 0
+  
+  Dim nItem&
+  For nItem = LBound(iResult) To UBound(iResult) Step 1
+    Dim nStart&: nStart = iResult(nItem, 0)
+    Dim nEnd&: nEnd = iResult(nItem, 1)
+    Dim nClass&: nClass = iResult(nItem, 2)
+    Call iData.AddItem(nStart, nEnd, nClass)
+  Next nItem
+
+SKIP_PYTHON:
+  Set ExtractFragments = iData
+End Function
+
+
+

parsers/DetectorListWords.cls

@@ -0,0 +1,105 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "DetectorListWords"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ====== Single word dictionary detector =======
+' Shared module version: 20220623
+' Tested in:
+' Depends on:
+' Required reference: ADODB, Scripting
+Option Explicit
+
+Private data_ As Scripting.Dictionary
+
+Public Function Init(sDictionaryPath$)
+  Set data_ = New Scripting.Dictionary
+  
+  On Error Resume Next
+  Call LoadFrom(sDictionaryPath)
+  On Error GoTo 0
+End Function
+
+Public Function Test(sText$) As Boolean
+  Test = data_.Exists(VBA.LCase(sText))
+End Function
+
+Public Function ExtractFragments(sText$) As PC_ParsedData
+  Dim iData As New PC_ParsedData
+  
+  Dim nStart&: nStart = 1
+  Dim nLen&: nLen = VBA.Len(sText)
+  Dim nCur&: nCur = nStart
+  Do While nCur <= nLen
+    If IsDelim(VBA.Mid$(sText, nCur, 1)) Then
+      If nCur > nStart Then _
+        If Test(VBA.Mid$(sText, nStart, nCur - nStart)) Then _
+          Call iData.AddItem(nStart - 1, nCur - 1)
+      nStart = nCur + 1
+    End If
+    nCur = nCur + 1
+  Loop
+  
+  If nCur > nStart Then _
+    If Test(VBA.Mid$(sText, nStart, nCur - nStart)) Then _
+      Call iData.AddItem(nStart - 1, nCur - 1)
+      
+  Set ExtractFragments = iData
+End Function
+
+' ========
+Public Function LoadFrom(sPath$)
+  Dim adoStream As New ADODB.Stream
+  adoStream.Charset = "utf-8"
+  Call adoStream.Open
+  Call adoStream.LoadFromFile(sPath)
+  
+  Dim nLine&: nLine = 1
+  Do Until adoStream.EOS
+    Dim sItem$: sItem = adoStream.ReadText(adReadLine)
+    If sItem <> "" And Not data_.Exists(sItem) Then _
+      Call data_.Add(VBA.LCase(sItem), nLine)
+    nLine = nLine + 1
+  Loop
+  
+  Call adoStream.Close
+End Function
+
+' ==========
+Private Function IsDelim(sSymbol$) As Boolean
+  IsDelim = True
+  If sSymbol = "." Then
+    Exit Function
+  ElseIf sSymbol = Chr(13) Then
+    Exit Function
+  ElseIf sSymbol = Chr(10) Then
+    Exit Function
+  ElseIf sSymbol = "," Then
+    Exit Function
+  ElseIf sSymbol = ChrW(&H2013) Then _
+    Exit Function
+  ElseIf sSymbol = ChrW(&H2012) Then _
+    Exit Function
+  ElseIf sSymbol = ChrW(&H2010) Then _
+    Exit Function
+  ElseIf sSymbol = ";" Then
+    Exit Function
+  ElseIf sSymbol = " " Then
+    Exit Function
+  ElseIf sSymbol = "!" Then
+    Exit Function
+  ElseIf sSymbol = ":" Then
+    Exit Function
+  ElseIf sSymbol = "?" Then
+    Exit Function
+  ElseIf sSymbol = """" Then
+    Exit Function
+  ElseIf sSymbol = "Chr(85)" Then
+    Exit Function
+  End If
+  IsDelim = False
+End Function

parsers/DetectorMorpho.cls

@@ -0,0 +1,47 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "DetectorMorpho"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ====== Morphology expression detector =======
+' Shared module version: 20220613
+' Tested in:
+' Depends on:
+' Required reference: API_Python, ex_Python
+Option Explicit
+
+Private tags_ As String
+
+Public Function Init(sTags$)
+  tags_ = sTags
+End Function
+
+Public Function Test(sText$) As Boolean
+  If tags_ = vbNullString Then _
+    Exit Function
+  Test = AccessPython.CallFunction(PY_MODULE_TEXT, "parse", Array(sText, tags_)) <> ""
+End Function
+
+Public Function ExtractFragments(sText$) As PC_ParsedData
+  Dim iData As New PC_ParsedData
+  
+  On Error GoTo SKIP_PYTHON
+  Dim iResult As Variant
+  iResult = AccessPython.CallFunction(PY_MODULE_TEXT, "match_all_morpho", Array(sText, tags_))
+  On Error GoTo 0
+  
+  Dim nItem&
+  For nItem = LBound(iResult) To UBound(iResult) Step 1
+    Dim nStart&: nStart = iResult(nItem, 0)
+    Dim nEnd&: nEnd = iResult(nItem, 1)
+    Call iData.AddItem(nStart, nEnd)
+  Next nItem
+
+SKIP_PYTHON:
+  Set ExtractFragments = iData
+End Function
+

parsers/DetectorRegex.cls

@@ -0,0 +1,42 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "DetectorRegex"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ====== Regular expression based detector =======
+' Shared module version: 20220613
+' Tested in:
+' Depends on:
+' Required reference: VBScript_RegExp_55
+Option Explicit
+
+Private regex_ As RegExp
+
+Public Function Init(theRegex As RegExp)
+  Set regex_ = theRegex
+End Function
+
+Public Function Test(sText$) As Boolean
+  Dim matches As Object: Set matches = regex_.Execute(sText)
+  If matches.Count <> 1 Then _
+    Exit Function
+  Test = matches.Item(0).Length = VBA.Len(sText)
+End Function
+
+Public Function ExtractFragments(sText$) As PC_ParsedData
+  Dim iData As New PC_ParsedData
+  
+  Dim matches As Object: Set matches = regex_.Execute(sText)
+  Dim nMatch&
+  For nMatch = 0 To matches.Count - 1 Step 1
+    Dim nStart&: nStart = matches.Item(nMatch).FirstIndex
+    Dim nEnd&: nEnd = nStart + matches.Item(nMatch).Length
+    Call iData.AddItem(nStart, nEnd)
+  Next nMatch
+  
+  Set ExtractFragments = iData
+End Function

parsers/ExtractionOptions.cls

@@ -0,0 +1,44 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "ExtractionOptions"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ================ Ïàðàìåòðû èçâëå÷åíèÿ è çàãðóçêè äàííûõ =========================
+' Shared module version: 20220614
+' Tested in:
+' Depends on: ParserDeclarations
+' Required reference:
+Option Explicit
+
+Public detector_ As TDetector
+Public param_ As String
+Public transform_ As String
+Public loadCategory_ As Long
+
+Private Sub Class_Initialize()
+  detector_ = T_DETECTOR_UNKNOWN
+  loadCategory_ = 0
+End Sub
+
+Public Function FromFlatData(iData As Variant)
+  detector_ = CLng(iData(1))
+  param_ = iData(2)
+  transform_ = iData(3)
+  loadCategory_ = CLng(iData(4))
+End Function
+
+Public Function AsFlatData() As String()
+  Dim iData() As String
+  ReDim iData(1 To 4)
+
+  iData(1) = detector_
+  iData(2) = param_
+  iData(3) = transform_
+  iData(4) = loadCategory_
+  
+  AsFlatData = iData
+End Function

parsers/PC_Fragment.cls

@@ -0,0 +1,34 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "PC_Fragment"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ====== Ïîëîæåíèÿ ôðàãìåíòà â òåêñòå =======
+' Shared module version: 20210909
+' Tested in:
+' Depends on:
+' Required reference:
+Option Explicit
+
+Public start_ As Long
+Public end_ As Long
+Public type_ As Long
+
+Public Function Init(nStart&, nEnd&, nType&)
+  start_ = nStart
+  end_ = nEnd
+  type_ = nType
+End Function
+
+Public Function Clone() As PC_Fragment
+  Set Clone = New PC_Fragment
+  With Clone
+    .start_ = start_
+    .end_ = end_
+    .type_ = type_
+  End With
+End Function

parsers/PC_InfoNPA.cls

@@ -0,0 +1,58 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "PC_InfoNPA"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ====== Legal document attributes =======
+' Shared module version: 20220614
+' Tested in:
+' Depends on:
+' Required reference: Scripting
+Option Explicit
+
+Public prefix_ As String
+Public date_ As String
+Public number_ As String
+Public docType_ As String
+Public creator_ As String
+Public title_ As String
+Public titlePrefix_ As String
+Public titleDoc_ As String
+
+Public isTimeBound_ As Boolean
+
+Private Sub Class_Initialize()
+  isTimeBound_ = False
+End Sub
+
+Public Function AsCollection() As Collection
+  Dim iData As New Collection
+  Call iData.Add(prefix_)
+  Call iData.Add(docType_)
+  Call iData.Add(creator_)
+  Call iData.Add(number_)
+  Call iData.Add(date_)
+  Call iData.Add(title_)
+  Call iData.Add(titlePrefix_)
+  Call iData.Add(titleDoc_)
+  Call iData.Add(isTimeBound_)
+  Set AsCollection = iData
+End Function
+
+Public Function AsDescription() As Scripting.Dictionary
+  Dim iData As New Scripting.Dictionary
+  Call iData.Add("ïðåôèêñ", prefix_)
+  Call iData.Add("òèï äîêóìåíòà", docType_)
+  Call iData.Add("âûïóñêàþùèé îðãàí", creator_)
+  Call iData.Add("íîìåð", number_)
+  Call iData.Add("äàòà", date_)
+  Call iData.Add("íàçâàíèå", title_)
+  Call iData.Add("ïðåôèêñ òèòóëà", titlePrefix_)
+  Call iData.Add("âëîæåííûé äîêóìåíò", titleDoc_)
+  Call iData.Add("ñðî÷íûé", isTimeBound_)
+  Set AsDescription = iData
+End Function

parsers/PC_ParsedData.cls

@@ -0,0 +1,42 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "PC_ParsedData"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ====== Ïîëîæåíèÿ íàáîðà ôðàãìåíòîâ â òåêñòå =======
+' Shared module version: 20220614
+' Tested in:
+' Depends on: PC_Fragment, ParserDeclarations
+' Required reference:
+Option Explicit
+
+Public data_ As New Collection
+
+Public Property Get Count() As Long
+  Count = data_.Count
+End Property
+
+Public Property Get IsEmpty() As Boolean
+  IsEmpty = Count = 0
+End Property
+
+Public Property Get First() As PC_Fragment
+  If IsEmpty Then _
+    Exit Property
+  Set First = data_.Item(1)
+End Property
+
+Public Property Get Last() As PC_Fragment
+  If IsEmpty Then _
+    Exit Property
+  Set Last = data_.Item(data_.Count)
+End Property
+
+Public Function AddItem(nStart&, nEnd&, Optional nType& = 0)
+  Dim newItem As New PC_Fragment: Call newItem.Init(nStart, nEnd, nType)
+  Call data_.Add(newItem)
+End Function

parsers/PC_Tools.cls

@@ -0,0 +1,127 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "PC_Tools"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ====== Äîñòóï ê ðàçëè÷íûì ïàðñåðàì =======
+' Shared module version: 20220801
+' Tested in:
+' Depends on: ParserDeclarations, DetectorListWords, DetectorRegex, DetectorMorpho, DetectorClassifier
+' Required reference:
+Option Explicit
+
+Public Function Detector(iType As TDetector, sParam$) As Object
+' Any Detector implements methods:
+'   Public Function Test(sText$) As Boolean
+'   Public Function ExtractFragments(sText$) As PC_ParsedData
+  Select Case iType
+    Case TDetector.T_DETECTOR_ACTION: Set Detector = CachedActionDetector
+    Case TDetector.T_DETECTOR_LIST: Set Detector = CachedDetectorList(sParam)
+    Case TDetector.T_DETECTOR_REGEX: Set Detector = CachedDetectorRegex(sParam)
+    Case TDetector.T_DETECTOR_MORPHO: Set Detector = CachedDetectorMorpho(sParam)
+    Case TDetector.T_DETECTOR_DATE:
+      Set Detector = New DetectorRegex: Call Detector.Init(GlobalDateRegex)
+    Case TDetector.T_DETECTOR_NPA:
+      Set Detector = New DetectorRegex: Call Detector.Init(GlobalNPARegex)
+    Case TDetector.T_DETECTOR_BASIC_NER: Set Detector = CachedDetectorNER(sParam)
+  End Select
+  If Detector Is Nothing Then _
+    Call Err.Raise(CUSTOM_ERROR_DEBUG)
+End Function
+
+Public Function Parser(iType As TDetector, sParam$) As Object
+' Any Parser implements methods:
+'   Public Function Test(sText$) As Boolean
+'   Public Function Parse(sText$) As Boolean
+'   Public Function GetData() As Collection
+'   Public Function GetDataDescription() As Scripting.Dictionary
+'   Public Function Transform(sText$, sParam$) As String
+  Select Case iType
+    Case TDetector.T_DETECTOR_ACTION: Set Parser = Nothing
+    Case TDetector.T_DETECTOR_LIST: Set Parser = Nothing
+    Case TDetector.T_DETECTOR_REGEX: Set Parser = Nothing
+    Case TDetector.T_DETECTOR_MORPHO: Set Parser = Nothing
+    Case TDetector.T_DETECTOR_DATE: Set Parser = CachedParserDate
+    Case TDetector.T_DETECTOR_NPA: Set Parser = CachedParserNPA
+    Case TDetector.T_DETECTOR_BASIC_NER: Set Parser = Nothing
+  End Select
+End Function
+
+' ========
+Private Function CachedActionDetector() As DetectorListWords
+  Static s_Detector As DetectorListWords
+  If s_Detector Is Nothing Then
+    Set s_Detector = New DetectorListWords
+    Call s_Detector.Init(LOCAL_MODELS & "\" & MODEL_ACTION_VERBS)
+  End If
+  Set CachedActionDetector = s_Detector
+End Function
+
+Private Function CachedDetectorList(sParam$) As DetectorListWords
+  Static s_Param$
+  Static s_Detector As DetectorListWords
+  If s_Detector Is Nothing Or sParam <> s_Param Then
+    s_Param = sParam
+    Set s_Detector = New DetectorListWords
+    Call s_Detector.Init(sParam)
+  End If
+  Set CachedDetectorList = s_Detector
+End Function
+
+Private Function CachedDetectorRegex(sParam$) As DetectorRegex
+  Static s_Regex As RegExp
+  Static s_Param$
+  Static s_Detector As DetectorRegex
+  If s_Detector Is Nothing Or sParam <> s_Param Then
+    s_Param = sParam
+    Set s_Regex = New RegExp
+    s_Regex.Global = True
+    s_Regex.Pattern = sParam
+    
+    Set s_Detector = New DetectorRegex
+    Call s_Detector.Init(s_Regex)
+  End If
+  Set CachedDetectorRegex = s_Detector
+End Function
+
+Private Function CachedDetectorMorpho(sParam$) As DetectorMorpho
+  Static s_Param$
+  Static s_Detector As DetectorMorpho
+  If s_Detector Is Nothing Or sParam <> s_Param Then
+    s_Param = sParam
+    Set s_Detector = New DetectorMorpho
+    Call s_Detector.Init(sParam)
+  End If
+  Set CachedDetectorMorpho = s_Detector
+End Function
+
+Private Function CachedParserDate() As ParserDate
+  Static s_Parser As ParserDate
+  If s_Parser Is Nothing Then
+    Set s_Parser = New ParserDate
+  End If
+  Set CachedParserDate = s_Parser
+End Function
+
+Private Function CachedParserNPA() As ParserNPA
+  Static s_Parser As ParserNPA
+  If s_Parser Is Nothing Then
+    Set s_Parser = New ParserNPA
+  End If
+  Set CachedParserNPA = s_Parser
+End Function
+
+Private Function CachedDetectorNER(sParam$) As DetectorClassifier
+  Static s_Param$
+  Static s_Detector As DetectorClassifier
+  If s_Detector Is Nothing Or sParam <> s_Param Then
+    s_Param = sParam
+    Set s_Detector = New DetectorClassifier
+    Call s_Detector.Init(sParam)
+  End If
+  Set CachedDetectorNER = s_Detector
+End Function

parsers/ParserDate.cls

@@ -0,0 +1,151 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "ParserDate"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ========= Date parser ==========
+' Shared module version: 20220614
+' Tested in: TestCommons
+' Depends on: z_ParserRegex
+' Required reference: VBScript_RegExp_55
+Option Explicit
+
+Private rxDate_ As RegExp
+
+Public day_ As Integer
+Public month_ As Integer
+Public year_ As Integer
+
+Private Sub Class_Initialize()
+  Set rxDate_ = New RegExp
+  rxDate_.Pattern = P_DATE_CAPTURE
+  rxDate_.Global = False
+End Sub
+
+Public Function Init(aDay%, aMonth%, aYear%)
+  day_ = aDay
+  month_ = aMonth
+  year_ = aYear
+End Function
+
+Public Function Test(target$) As Boolean
+  Test = rxDate_.Test(target)
+End Function
+
+Public Function Parse(target$) As Boolean
+  Parse = Test(target)
+  If Parse Then
+    Dim matches As Object
+    Set matches = rxDate_.Execute(target)
+    If matches.Item(0).SubMatches(0) <> vbNullString Then
+      day_ = CInt(matches.Item(0).SubMatches(0))
+      month_ = ConvertDateText2Int(matches.Item(0).SubMatches(1))
+      year_ = CInt(matches.Item(0).SubMatches(2))
+    Else
+      day_ = CInt(matches.Item(0).SubMatches(3))
+      month_ = CInt(matches.Item(0).SubMatches(4))
+      year_ = CInt(matches.Item(0).SubMatches(5))
+    End If
+  End If
+End Function
+
+Public Function GetData() As Collection
+  Set GetData = New Collection
+  Call GetData.Add(year_)
+  Call GetData.Add(month_)
+  Call GetData.Add(day_)
+End Function
+
+Public Function GetDataDescription() As Scripting.Dictionary
+  Dim iData As New Scripting.Dictionary
+  Call iData.Add("ãîä", year_)
+  Call iData.Add("ìåñÿö", month_)
+  Call iData.Add("äåíü", day_)
+  Set GetDataDescription = iData
+End Function
+
+Public Function Transform(sText$, sParam$) As String
+  If Not Parse(sText) Then
+    Transform = sText
+  ElseIf sParam = "1" Then
+    Transform = AsTextString
+  ElseIf sParam = "2" Then
+    Transform = AsDigitsString
+  Else
+    Transform = sText
+  End If
+End Function
+
+Public Property Get IsValidDate() As Boolean
+  IsValidDate = False
+  
+  If month_ > 12 Or month_ < 1 Then _
+    Exit Property
+  If day_ > 31 Or day_ < 1 Then _
+    Exit Property
+  
+  IsValidDate = IsDate(AsDigitsString)
+End Property
+
+Public Property Get DDate() As Double
+  If Not IsValidDate Then _
+    Exit Function
+  DDate = DateSerial(year_, month_, day_)
+End Property
+
+Public Function AsDigitsString() As String
+  AsDigitsString = Format(day_, "00") & "." & Format(month_, "00") & "." & Format(year_, IIf(year_ > 100, "0000", "00"))
+End Function
+
+Public Function AsTextString() As String
+  If Not IsValidDate Then
+    AsTextString = "INVALID_DATE"
+  Else
+    AsTextString = Format(day_, "00") & " " & MonthStr(month_) & " " & Year(DateSerial(year_, 1, 1)) & " ãîäà"
+  End If
+End Function
+
+' ============
+Private Function ConvertDateText2Int(sMonth$) As Integer
+  If IsNumeric(sMonth) Then
+    ConvertDateText2Int = CInt(sMonth)
+    Exit Function
+  End If
+  Select Case sMonth
+    Case "ÿíâàðÿ": ConvertDateText2Int = 1
+    Case "ôåâðàëÿ": ConvertDateText2Int = 2
+    Case "ìàðòà": ConvertDateText2Int = 3
+    Case "àïðåëÿ": ConvertDateText2Int = 4
+    Case "ìàÿ": ConvertDateText2Int = 5
+    Case "èþíÿ": ConvertDateText2Int = 6
+    Case "èþëÿ": ConvertDateText2Int = 7
+    Case "àâãóñòà": ConvertDateText2Int = 8
+    Case "ñåíòÿáðÿ": ConvertDateText2Int = 9
+    Case "îêòÿáðÿ": ConvertDateText2Int = 10
+    Case "íîÿáðÿ": ConvertDateText2Int = 11
+    Case "äåêàáðÿ": ConvertDateText2Int = 12
+    Case Else: ConvertDateText2Int = 0
+  End Select
+End Function
+
+Private Function MonthStr(nMonth%) As String
+  Select Case nMonth
+    Case 1: MonthStr = "ÿíâàðÿ"
+    Case 2: MonthStr = "ôåâðàëÿ"
+    Case 3: MonthStr = "ìàðòà"
+    Case 4: MonthStr = "àïðåëÿ"
+    Case 5: MonthStr = "ìàÿ"
+    Case 6: MonthStr = "èþíÿ"
+    Case 7: MonthStr = "èþëÿ"
+    Case 8: MonthStr = "àâãóñòà"
+    Case 9: MonthStr = "ñåíòÿáðÿ"
+    Case 10: MonthStr = "îêòÿáðÿ"
+    Case 11: MonthStr = "íîÿáðÿ"
+    Case 12: MonthStr = "äåêàáðÿ"
+    Case Else: MonthStr = "INVALID MONTH"
+  End Select
+End Function

parsers/ParserDeclarations.bas

@@ -0,0 +1,54 @@
+Attribute VB_Name = "ParserDeclarations"
+' ======== Parser declarations ========
+' Shared module version: 20220614
+' Tested in:
+' Depends on:
+' Required reference:
+Option Private Module
+Option Explicit
+
+Public Const LOCAL_MODELS = "C:\Tools\models"
+Public Const MODEL_ACTION_VERBS = "ActionVerbs.txt"
+
+Public Const CUSTOM_ERROR_DEBUG = 1025
+
+Public Enum TDetector
+  [_First] = 1
+  
+  T_DETECTOR_UNKNOWN = 0
+  T_DETECTOR_REGEX = 1
+  T_DETECTOR_MORPHO = 2
+  T_DETECTOR_LIST = 3
+  T_DETECTOR_DATE = 4
+  T_DETECTOR_ACTION = 5
+  T_DETECTOR_NPA = 6
+  T_DETECTOR_BASIC_NER = 7
+  
+  [_Last] = 7
+End Enum
+
+Public Function DetectorFromStr(sName$) As TDetector
+  Select Case sName
+  Case "Äàòà":        DetectorFromStr = T_DETECTOR_DATE
+  Case "Äåéñòâèå":    DetectorFromStr = T_DETECTOR_ACTION
+  Case "Ñïèñîê ñëîâ": DetectorFromStr = T_DETECTOR_LIST
+  Case "RegExp":      DetectorFromStr = T_DETECTOR_REGEX
+  Case "Ìîðôîëîãèÿ":  DetectorFromStr = T_DETECTOR_MORPHO
+  Case "ÍÏÀ":         DetectorFromStr = T_DETECTOR_NPA
+  Case "Èì. ñóùíîñòè": DetectorFromStr = T_DETECTOR_BASIC_NER
+  Case Else: DetectorFromStr = T_DETECTOR_UNKNOWN
+  End Select
+End Function
+
+Public Function DetectorToStr(iType As TDetector) As String
+  Select Case iType
+  Case T_DETECTOR_UNKNOWN:  DetectorToStr = "Íåîïðåäåëåííàÿ"
+  Case T_DETECTOR_DATE:     DetectorToStr = "Äàòà"
+  Case T_DETECTOR_ACTION:   DetectorToStr = "Äåéñòâèå"
+  Case T_DETECTOR_LIST:     DetectorToStr = "Ñïèñîê ñëîâ"
+  Case T_DETECTOR_REGEX:    DetectorToStr = "RegExp"
+  Case T_DETECTOR_MORPHO:   DetectorToStr = "Ìîðôîëîãèÿ"
+  Case T_DETECTOR_NPA:      DetectorToStr = "ÍÏÀ"
+  Case T_DETECTOR_BASIC_NER: DetectorToStr = "Èì. ñóùíîñòè"
+  End Select
+End Function

parsers/ParserNPA.cls

@@ -0,0 +1,179 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "ParserNPA"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ====== Legal document title parser =======
+' Shared module version: 20220614
+' Tested in:
+' Depends on:
+' Required reference:  z_ParserRegex, PC_InfoNPA
+Option Explicit
+
+Private rxTitleFirst_ As RegExp
+Private rxTitleLast_ As RegExp
+Private rxCreatorPrefix_ As RegExp
+Private rxTitle_ As RegExp
+Private rxImmediate_ As RegExp
+
+Public data_ As New PC_InfoNPA
+
+Private Sub Class_Initialize()
+  Set rxTitleFirst_ = New RegExp
+  rxTitleFirst_.Pattern = P_NPA_TITLE_FIRST
+  rxTitleFirst_.Global = False
+  
+  Set rxTitleLast_ = New RegExp
+  rxTitleLast_.Pattern = P_NPA_PROPS_FIRST
+  rxTitleLast_.Global = False
+  
+  Set rxCreatorPrefix_ = New RegExp
+  rxCreatorPrefix_.Pattern = P_NPA_DOCTYPE
+  rxCreatorPrefix_.Global = False
+  
+  Set rxTitle_ = New RegExp
+  rxTitle_.Pattern = P_NPA_COMPOSITE_TITLE
+  rxTitle_.Global = False
+  
+  Set rxImmediate_ = New RegExp
+  rxImmediate_.Pattern = P_NPA_IMMEDIATE
+  rxImmediate_.Global = False
+End Sub
+
+Public Function Test(target$) As Boolean
+  Test = rxTitleLast_.Test(target)
+  If Not Test Then Test = rxTitleFirst_.Test(target)
+End Function
+
+Public Function Parse(target$) As Boolean
+  Set data_ = New PC_InfoNPA
+  Dim matches As Object
+  Dim isTitleLast As Boolean
+  isTitleLast = rxTitleLast_.Test(target)
+  If Not isTitleLast Then
+    If Not rxTitleFirst_.Test(target) Then
+      Parse = False
+      Exit Function
+    End If
+  End If
+ 
+  Parse = True
+  If isTitleLast Then
+    Set matches = rxTitleLast_.Execute(target)
+    data_.prefix_ = matches.Item(0).SubMatches(0)
+    data_.date_ = matches.Item(0).SubMatches(1)
+    data_.number_ = Trim(matches.Item(0).SubMatches(2))
+    data_.title_ = Trim(matches.Item(0).SubMatches(3))
+  Else
+    Set matches = rxTitleFirst_.Execute(target)
+    data_.title_ = Trim(matches.Item(0).SubMatches(0))
+    data_.prefix_ = Trim(matches.Item(0).SubMatches(1))
+    data_.date_ = Trim(matches.Item(0).SubMatches(2))
+    data_.number_ = Trim(matches.Item(0).SubMatches(3))
+  End If
+  
+  Call ParsePrefix
+  Call ParseTitle
+End Function
+
+Public Function GetData() As Collection
+  Set GetData = data_.AsCollection()
+End Function
+
+Public Function GetDataDescription() As Scripting.Dictionary
+  Set GetDataDescription = data_.AsDescription()
+End Function
+
+Public Function Transform(sText$, sParam$) As String
+  Transform = sText
+End Function
+
+' =======
+Private Function ParsePrefix()
+  If data_.prefix_ = vbNullString Then _
+    Exit Function
+  If Not rxCreatorPrefix_.Test(data_.prefix_) Then
+    data_.creator_ = data_.prefix_
+    Exit Function
+  End If
+  
+  Dim matches As Object: Set matches = rxCreatorPrefix_.Execute(data_.prefix_)
+  data_.docType_ = CapitalizeFirstLetter(Trim(matches.Item(0).Value))
+  If Len(data_.docType_) <> Len(data_.prefix_) Then _
+    data_.creator_ = Trim(Right(data_.prefix_, Len(data_.prefix_) - Len(data_.docType_)))
+  Call FixTypeCase
+End Function
+
+Private Function ParseTitle()
+  Dim theTitle$: theTitle = data_.title_
+  If theTitle = vbNullString Then _
+    Exit Function
+    
+  data_.isTimeBound_ = rxImmediate_.Test(theTitle)
+    
+  If Not rxTitle_.Test(theTitle) Then _
+    Exit Function
+  
+  Dim matches As Object: Set matches = rxTitle_.Execute(theTitle)
+  data_.titlePrefix_ = Trim(matches.Item(0).SubMatches(0))
+  data_.titleDoc_ = Trim(matches.Item(0).SubMatches(1))
+End Function
+
+Private Function FixTypeCase()
+  If Len(data_.docType_) = 0 Then _
+    Exit Function
+    
+  Select Case Left(data_.docType_, 1)
+    Case "Ä"
+      data_.docType_ = Replace(data_.docType_, "Äèðåêòèâû", "Äèðåêòèâà")
+      data_.docType_ = Replace(data_.docType_, "Äèðåêòèâîé", "Äèðåêòèâà")
+      data_.docType_ = Replace(data_.docType_, "Äèðåêòèâå", "Äèðåêòèâà")
+    Case "Ç"
+      data_.docType_ = Replace(data_.docType_, "Çàêëþ÷åíèåì", "Çàêëþ÷åíèå")
+      data_.docType_ = Replace(data_.docType_, "Çàêëþ÷åíèÿ", "Çàêëþ÷åíèå")
+      data_.docType_ = Replace(data_.docType_, "Çàêëþ÷åíèþ", "Çàêëþ÷åíèå")
+      data_.docType_ = Replace(data_.docType_, "Çàêîíîì", "Çàêîí")
+      data_.docType_ = Replace(data_.docType_, "Çàêîíà", "Çàêîí")
+      data_.docType_ = Replace(data_.docType_, "Çàêîíó", "Çàêîí")
+    Case "È"
+      data_.docType_ = Replace(data_.docType_, "Èíôîðìàöèîííîãî ïèñüìà", "Èíôîðìàöèîííîå ïèñüìî")
+      data_.docType_ = Replace(data_.docType_, "Èíôîðìàöèîííûì ïèñüìîì", "Èíôîðìàöèîííîå ïèñüìî")
+      data_.docType_ = Replace(data_.docType_, "Èíôîðìàöèîííîìó ïèñüìó", "Èíôîðìàöèîííîå ïèñüìî")
+    Case "Ï"
+      data_.docType_ = Replace(data_.docType_, "Ïðèêàçîì", "Ïðèêàç")
+      data_.docType_ = Replace(data_.docType_, "Ïðèêàçà", "Ïðèêàç")
+      data_.docType_ = Replace(data_.docType_, "Ïðèêàçó", "Ïðèêàç")
+      data_.docType_ = Replace(data_.docType_, "Ïèñüìîì", "Ïèñüìî")
+      data_.docType_ = Replace(data_.docType_, "Ïèñüìà", "Ïèñüìî")
+      data_.docType_ = Replace(data_.docType_, "Ïèñüìó", "Ïèñüìî")
+    Case "Ð"
+      data_.docType_ = Replace(data_.docType_, "Ðàñïîðÿæåíèåì", "Ðàñïîðÿæåíèå")
+      data_.docType_ = Replace(data_.docType_, "Ðàñïîðÿæåíèÿ", "Ðàñïîðÿæåíèå")
+      data_.docType_ = Replace(data_.docType_, "Ðàñïîðÿæåíèþ", "Ðàñïîðÿæåíèå")
+      data_.docType_ = Replace(data_.docType_, "Ðåøåíèåì", "Ðåøåíèå")
+      data_.docType_ = Replace(data_.docType_, "Ðåøåíèÿ", "Ðåøåíèå")
+      data_.docType_ = Replace(data_.docType_, "Ðåøåíèþ", "Ðåøåíèå")
+    Case "Ó"
+      If data_.docType_ = "Óêàçà" Then
+        data_.docType_ = "Óêàç"
+      Else
+        data_.docType_ = Replace(data_.docType_, "Óêàçîì", "Óêàç")
+        data_.docType_ = Replace(data_.docType_, "Óêàçó", "Óêàç")
+        data_.docType_ = Replace(data_.docType_, "Óêàçàíèÿ", "Óêàçàíèå")
+        data_.docType_ = Replace(data_.docType_, "Óêàçàíèåì", "Óêàçàíèå")
+        data_.docType_ = Replace(data_.docType_, "Óêàçàíèþ", "Óêàçàíèå")
+      End If
+    Case "Ô"
+      data_.docType_ = Replace(data_.docType_, "Ôåäåðàëüíûì", "Ôåäåðàëüíûé")
+      data_.docType_ = Replace(data_.docType_, "Ôåäåðàëüíîãî", "Ôåäåðàëüíûé")
+      data_.docType_ = Replace(data_.docType_, "Ôåäåðàëüíîìó", "Ôåäåðàëüíûé")
+      data_.docType_ = Replace(data_.docType_, "çàêîíîì", "çàêîí")
+      data_.docType_ = Replace(data_.docType_, "çàêîíà", "çàêîí")
+      data_.docType_ = Replace(data_.docType_, "çàêîíó", "çàêîí")
+  End Select
+End Function
+

parsers/z_ParserRegex.bas

@@ -0,0 +1,232 @@
+Attribute VB_Name = "z_ParserRegex"
+' ======== Parser regex masks ========
+' Shared module version: 20210909
+' Tested in:
+' Depends on:
+' Required reference:
+Option Private Module
+Option Explicit
+
+Private Const P_SPACE = "(?:\s+?)"
+
+Private Const P_QUOTE_OPEN = "[""'«“]"
+Private Const P_QUOTE_CLOSE = "[""'»”]"
+Private Const P_ANY_SHORTEST = ".*?"
+Private Const P_ANY = ".*"
+
+Private Const P_MONTH_RUS = "(?:ÿíâàðÿ|ôåâðàëÿ|ìàðòà|àïðåëÿ|ìàÿ|èþíÿ|èþëÿ|àâãóñòà|ñåíòÿáðÿ|îêòÿáðÿ|íîÿáðÿ|äåêàáðÿ)"
+Private Const P_MONTH_DIGITS = "[0-1]?\d"
+Private Const P_DAY_DIGITS = "[0-3]?\d"
+Private Const P_YEAR_LONG = "[1-2]\d\d\d"
+Private Const P_YEAR_SHORT = "\d\d"
+Private Const P_YEAR_DIGITS = "(?:" & P_YEAR_LONG & "|" & P_YEAR_SHORT & ")"
+  
+Private Const P_DATE_TEXT = _
+  "(" & P_DAY_DIGITS & ")" & P_SPACE & _
+  "(" & P_MONTH_RUS & ")" & P_SPACE & _
+  "(" & P_YEAR_LONG & ")"
+  
+Private Const P_DATE_NUMERIC = _
+  "(" & P_DAY_DIGITS & ")" & "\." & _
+  "(" & P_MONTH_DIGITS & ")" & "\." & _
+  "(" & P_YEAR_DIGITS & ")"
+  
+Private Const P_NPA_PREFIX = "[À-ßà-ÿ][\dÀ-ßà-ÿA-Za-z,\-\.""'«»“”\s]+?"
+Private Const P_NPA_ID_ELEMENT = "[#N¹]" & P_SPACE & "?" & "[\dÀ-ßà-ÿA-Za-z_@\.\-\\/]+"
+Private Const P_NPA_ID_SEQ = P_NPA_ID_ELEMENT & "(?:," & P_SPACE & P_NPA_ID_ELEMENT & ")*"
+Private Const P_NPA_INTRO = _
+  "(?:" & _
+    "[Ïï]ðèëîæåíèå ê" & "|" & _
+    "[Ââ] ðåäàêöèè" & "|" & _
+    "(?:" & _
+      "[Ðð]åêîìåíäîâàí[àîû]?" & "|" & _
+      "(?:" & _
+        "[Óó]òâ\." & "|" & _
+        "[Óó]òâåðæä(?:[å¸]í|åíà|åíî|åíû)" & _
+      ")" & " è ââåä(?:[å¸]í|åíà|åíî|åíû) â äåéñòâèå" & "|" & _
+      "(?:ïðèíÿò[àîû]? è )?" & _
+      "(?:" & _
+        "[Óó]òâ\." & "|" & _
+        "[Óó]òâåðæä(?:[å¸]í|åíà|åíî|åíû)" & "|" & _
+        "îäîáðåí[àîû]?" & "|" & _
+        "[Ââ]âåä(?:[å¸]í|åíà|åíî|åíû) â äåéñòâèå" & _
+      ")" & "|" & _
+      "ïðèíÿò[àîû]?" & _
+    ")" & "(?: íà)?" & _
+  ")"
+
+Private Const P_MASK_DOCTYPE = _
+  "(?:" & _
+    "[Êê]îíñòèòóàöè[ÿè]" & "|" & _
+    "[Ôô]åäåðàëüí(?:ûé|ûì|îãî|îìó) çàêîí(?:îì|à|ó)?" & "|" & _
+    "[Ôô]åäåðàëüí(?:ûé|ûì|îãî|îìó) [Êê]îíñòèòóöèîíí(?:ûé|ûì|îãî|îìó)] çàêîí(?:îì|à|ó)?" & "|" & _
+    "[Çç]àêîí(?:îì|à|ó)?(?: ÐÔ| Ðîññèéñêîé Ôåäåðàöèè)?" & "|" & _
+    "[Ää]èðåêòèâ(?:à|îé|û|å)" & "|" & _
+    P_ANY & "[Êê]îäåêñ(?:îì)?" & P_ANY & "|" & _
+    P_ANY & "[Êê]îíâåíöè(?:ÿ|åé|èè)" & "|" & _
+    "[Óó]êàçàíè(?:åì|å|ÿ|þ)" & "|" & _
+    "[Çç]àêëþ÷åíè(?:åì|å|ÿ|þ)" & "|" & _
+    "[Ïï]èñüì(?:îì|î|à|ó)" & "|" & _
+    "[Ðð]àçúÿñíåíè(?:åì|å|ÿ|þ)" & "|" & _
+    "[Ïï]îñòàíîâëåíè(?:åì|å|ÿ|þ)" & "|" & _
+    "[Ïï]ðèêàç(?:îì|à|ó)?" & "|" & _
+    "[Óó]êàç(?:îì|à|ó)?" & "|" & _
+    "[Èè]íôîðìàöèîíí(?:îå|ûì|îãî|îìó) ïèñüì(?:îì|î|à|ó)" & "|" & _
+    "[Ðð]àñïîðÿæåíè(?:åì|å|ÿ|þ)" & "|" & _
+    "[Ññ]îãëàøåíè(?:åì|å|ÿ|þ)(?: î âçàèìîäåéñòâèè)?" & "|" & _
+    "[Ðð]åøåíè(?:åì|å|ÿ|þ)" & _
+  ")"
+
+Private Const P_NPA_TITLE_PREFIX = _
+  "(?:" & _
+    "[Îî] ââåäåíèè â äåéñòâèå" & "(?: íîâîé ðåäàêöèè)?" & "|" & _
+    "[Îî]á èçäàíèè è ïðèìåíåíèè" & "|" & _
+    "[Îî]á óòâåðæäåíèè(?: è(?: î)? ââåäåíèè â äåéñòâèå)?" & _
+  " " & _
+  ")"
+
+' ======================================
+' ======== Èòîãîâûå âûðàæåíèÿ ==========
+' ======================================
+
+' ======= Äàòà ==========
+Public Const P_DATE_NO_CAPTURE = _
+  "(?:" & _
+    P_DAY_DIGITS & P_SPACE & P_MONTH_RUS & P_SPACE & P_YEAR_LONG & _
+    "|" & _
+    P_DAY_DIGITS & "\." & P_MONTH_DIGITS & "\." & P_YEAR_DIGITS & _
+  ")" & _
+  "(?:" & P_SPACE & "?" & "(?:ãîäà|ã\.|ã))?"
+  
+Public Const P_DATE_CAPTURE = _
+  "^" & _
+    "(?:" & _
+      P_DATE_TEXT & "|" & _
+      P_DATE_NUMERIC & _
+    ")" & _
+    "(?:" & P_SPACE & "?" & "(?:ãîäà|ã\.|ã))?" & _
+  "$"
+  
+' ====== Íàçâàíèå ÍÏÀ ======
+Public Const P_NPA_SCAN = _
+  "(?:" & "\b[Ññ]ì\." & P_SPACE & ")?" & _
+  "(?:" & _
+      "\bâ ðåäàêöèè " & "|" & _
+      "\bâ ñîîòâåòñòâèè ñ " & _
+  ")?" & _
+  "(" & _
+    P_NPA_PREFIX & P_SPACE & "îò" & P_SPACE & P_DATE_NO_CAPTURE & P_SPACE & "?" & _
+    P_NPA_ID_SEQ & "(?:" & P_SPACE & P_QUOTE_OPEN & P_ANY & P_QUOTE_CLOSE & ")?" & _
+    "|" & _
+    P_ANY_SHORTEST & _
+    "\(" & _
+      P_ANY_SHORTEST & P_NPA_INTRO & P_SPACE & P_NPA_PREFIX & _
+      "(?:" & P_SPACE & "îò" & ")?" & P_SPACE & P_DATE_NO_CAPTURE & _
+      "(?:" & P_SPACE & "?" & "(?:" & P_NPA_ID_SEQ & "))?" & P_ANY_SHORTEST & _
+    "\)" & _
+  ")"
+
+Public Const P_NPA_PROPS_FIRST = _
+  "^" & _
+    "(" & P_NPA_PREFIX & ")" & _
+    P_SPACE & "îò" & P_SPACE & "(" & P_DATE_NO_CAPTURE & ")" & _
+    P_SPACE & "?" & "(" & P_NPA_ID_SEQ & ")" & _
+    "(?:" & P_SPACE & P_QUOTE_OPEN & "(" & P_ANY & ")" & P_QUOTE_CLOSE & ")?" & _
+    P_ANY_SHORTEST & _
+  "$"
+
+Public Const P_NPA_TITLE_FIRST = _
+  "^" & _
+    "(" & P_ANY_SHORTEST & ")" & _
+    "\(" & _
+      P_ANY_SHORTEST & P_NPA_INTRO & P_SPACE & _
+      "(" & P_NPA_PREFIX & ")" & P_SPACE & _
+      "(?:îò" & P_SPACE & ")?" & "(" & P_DATE_NO_CAPTURE & ")" & _
+      "(?:" & P_SPACE & "?" & "(" & P_NPA_ID_SEQ & "))?" & _
+      P_ANY_SHORTEST & _
+    "\)" & _
+    P_ANY_SHORTEST & _
+  "$"
+  
+' ===== Òèï äîêóìåíòà =========
+Public Const P_NPA_DOCTYPE = "^" & "(" & P_MASK_DOCTYPE & ")"
+
+' ======== Òèòóë äîêóìåíòà ======
+Public Const P_NPA_COMPOSITE_TITLE = _
+  "^" & _
+    "(" & P_NPA_TITLE_PREFIX & ")" & _
+    P_QUOTE_OPEN & "?" & _
+    "(" & P_ANY_SHORTEST & ")" & _
+    P_QUOTE_CLOSE & "?" & _
+  "$"
+
+' ======== Ñðî÷íîñòü äîêóìåíòà ===
+Public Const P_NPA_IMMEDIATE = _
+  " " & _
+  "(?:(?:ñ|íà|â|äî) |\()" & _
+  "(?:ïëàíîâûé |ïåðèîä |ïëàíîâûé ïåðèîä )?" & _
+  P_YEAR_DIGITS & _
+  "(?:" & _
+    "(?:\-| \- | è | ïî )" & _
+    P_YEAR_DIGITS & _
+  ")?" & _
+  " " & _
+  "(?:ãîä(?:îâ|à|û|àõ)?|ãã\.|ãã|ã\.|ã)"
+
+' ======== Static access for compiled regexp ======
+Public Function GlobalDateRegex() As RegExp
+  Static s_Regex As RegExp
+  If s_Regex Is Nothing Then
+    Set s_Regex = New RegExp
+    s_Regex.Global = True
+    s_Regex.Pattern = P_DATE_NO_CAPTURE
+  End If
+  Set GlobalDateRegex = s_Regex
+End Function
+
+Public Function GlobalNPARegex() As RegExp
+  Static s_Regex As RegExp
+  If s_Regex Is Nothing Then
+    Set s_Regex = New RegExp
+    s_Regex.Global = True
+    s_Regex.Pattern = P_NPA_SCAN
+  End If
+  Set GlobalNPARegex = s_Regex
+End Function
+
+' ============= Òèïû äîêóìåíòîâ-îïðåäåëåíèé
+' Ïîëîæåí(?:èÿ|èå|èè) îá?
+' Ïîðÿä(?:êà|îê|êå)
+' Ïðàâèëà?
+' (?:Àäìèíèñòðàòèâíîãî)?[Ðð]åãëàìåíòà?(?: ïî)?
+' Ðåêîìåíäàöè[èé] ïî
+' Ñòðàòåãè[èÿ]
+' Ñòðóêòóð[àû]
+' Òèïîâî(?:ãî|îå) ïîëîæåíè[ÿå] îá?
+' Òðåáîâàíèé(?:(?:, ïðåäúÿâëÿåìûõ)? ê)?
+' Ôîðì[àû]? è ïîðÿäêà
+' Ôîðì[àû]?
+' Ïåðå÷åíü
+
+' ============ Òèïû äîêóìåíòîâ-äåéñòâèé
+' Î âíåñåíèè èçìåíåíèé â
+' Î(?: íåêîòîðûõ| íåîòëîæíûõ| ïåðâîî÷åðåäíûõ)? ìåðàõ ïî (?:ðåàëèçàöèè|ñòèìóëèðîâàíèþ|ñîâåðøåíñòâîâàíèþ)
+' Î ìåðîïðèÿòèÿõ ïî
+' Î ïåðå÷íå
+' Î ïîäãîòîâêå ïðîåêòà
+' Î (ïîäïèñàíèè|ïðèíÿòèè|ðàòèôèêàöèè)
+' Î ðåàëèçàöèè
+' Î ñîçäàíèè(?: è âåäåíèè)?
+' Îá èçìåíåíèè ñîñòàâà
+' Îá îáðàçîâàíèè ' ÷åãî-ëèáî
+' Îá îáúÿâëåíèè ' Äðóãîãî äîêóìåíòà
+' Îá îðãàíèçàöèè(?: ðàáîòû? ïî)?
+' Îá îñóùåñòâëåíèè
+' Îá óñèëåíèè ' = cîâåðøåíñòâîâàíèå?
+' Îá óñòàíîâëåíèè ' çàäàíèå çíà÷åíèÿ
+' Îá îïðåäåëåíèè ' ïðîöåäóðà çàäàíèÿ çíà÷åíèÿ
+
+' ========= TODO
+' Ïàðñèòü âûäåëÿÿ îðãàíû-àêòîðû
+' Private Const P_ANY_SPECIAL_SPACE = "[ \xA0\u1680\u180E\u2000-\u200B\u202F\u205F\u3000\uFEFF]+"
+

samples/DB_Data_sample.cls

@@ -0,0 +1,57 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "DB_Data_sample"
+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 Count() As Long
+  Count = ILast.row_ - IBegin.row_ + 1
+End Property
+
+Public Function IBegin() As IteratorWorker
+  Set IBegin = New IteratorWorker
+  Call IBegin.Init(data_)
+End Function
+
+Public Function ILast() As IteratorWorker
+  Set ILast = New IteratorWorker
+  Call ILast.Init(data_)
+  Call ILast.GoLast
+End Function
+
+Public Function INew() As IteratorWorker
+  Set INew = New IteratorWorker
+  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 Contains(sWorkerID$) As Boolean
+  Contains = Not Access(sWorkerID) Is Nothing
+End Function
+
+Public Function Access(sWorkerID$) As IteratorWorker
+  Dim iWorker As IteratorWorker: Set iWorker = IBegin
+  Do While Not iWorker.IsDone
+    If iWorker.WorkerID = sWorkerID Then
+      Set Access = iWorker
+      Exit Function
+    End If
+    Call iWorker.Increment
+  Loop
+End Function

samples/DevHelper_sample.bas

@@ -0,0 +1,20 @@
+Attribute VB_Name = "DevHelper_sample"
+Option Explicit
+
+Public Function Dev_PrepareSkeleton()
+  ' Do nothing
+End Function
+
+Public Sub Dev_ManualRunTest()
+  Dim sSuite$: sSuite = "s_UndoWrapper"
+  Dim sTest$: sTest = "t_BasicUndo"
+  Dim sMsg$: sMsg = Dev_RunTestDebug(sSuite, sTest)
+  Debug.Print sMsg
+  Call MsgBox(sMsg)
+End Sub
+
+Public Function Dev_GetTestSuite(sName$) As Object
+  Select Case sName
+    Case "s_UndoWrapper": Set Dev_GetTestSuite = New s_UndoWrapper
+  End Select
+End Function

samples/Iterator_sample.cls

@@ -0,0 +1,81 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "Iterator_sample"
+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 GoFirst()
+  row_ = FIRST_ROW
+End Function
+
+Public Function GoLast()
+  row_ = data_.Columns(S_E_ID).Find(vbNullString, LookAt:=xlWhole).Row - 1
+End Function
+
+Public Function IsDone() As Boolean
+  IsDone = data_.Cells(row_, S_E_ID) = vbNullString
+End Function
+
+Public Function RemoveRow()
+  Call data_.Rows(row_).Delete
+End Function
+
+'===== Propertiy Get =====
+Public Property Get WorkerID() As String
+  WorkerID = data_.Cells(row_, S_E_ID)
+End Property
+
+Public Property Get WorkerName() As String
+  WorkerName = data_.Cells(row_, S_E_NAME)
+End Property
+
+Public Property Get Active() As Boolean
+  Active = data_.Cells(row_, S_E_ACTIVE) = 1
+End Property
+
+Public Property Get Hours() As Double
+  Hours = data_.Cells(row_, S_E_HOURS)
+End Property
+
+Public Property Get ReportPath() As String
+  ReportPath = data_.Cells(row_, S_E_PATH)
+End Property
+
+' ==== Property Let ====
+Public Property Let WorkerID(newVal$)
+  data_.Cells(row_, S_E_ID) = newVal
+End Property
+
+Public Property Let WorkerName(newVal$)
+  data_.Cells(row_, S_E_NAME) = newVal
+End Property
+
+Public Property Let Active(newVal As Boolean)
+  data_.Cells(row_, S_E_ACTIVE) = IIf(newVal, 1, 0)
+End Property
+
+Public Property Let Hours(newVal As Double)
+  data_.Cells(row_, S_E_HOURS) = newVal
+End Property
+
+Public Property Let ReportPath(newVal$)
+  data_.Cells(row_, S_E_PATH) = newVal
+End Property

samples/VBAMake_sample.txt

@@ -0,0 +1,31 @@
+# == Properties Section ==
+# configuration properties
+# use .ini format to define properties
+# mandatory properties: name, artifact_home, source_home, install_home
+
+name = 
+description = 
+artifact_home = 
+source_home = 
+install_home = 
+
+%%
+# === Build section ===
+# Available commands:
+#   build LOCAL_MANIFEST
+#   copy LOCAL_SOURCE -> [LOCAL_ARTIFACT]
+#   save_as LOCAL_ARTIFACT -> LOCAL_ARTIFACT
+#   run LOCAL_SOURCE.bat <- [PARAMETERS]
+#	run APPLICATION <- [PARAMETERS]
+
+
+
+%%
+# === Install section ==
+# Available commands:
+#	install LOCAL_ARTIFACT -> [INSTALL_PATH]
+#	add_template LOCAL_ARTIFACT -> [LOCAL_TEMPLATE]
+#   run LOCAL_ARTIFACT.bat <- [PARAMETERS]
+#	run APPLICATION <- [PARAMETERS]
+
+

samples/manifest_sample.txt

@@ -0,0 +1,38 @@
+# == Properties Section ==
+# configuration properties
+# use .ini format to define properties
+# mandatory properties: name, artifact
+
+name = 
+artifact = 
+
+%%
+# === Imports Section ===
+# Hierarchy of folders and files
+# Use Tabulator to mark next level in hierarchy
+# All folders are nested into SharedHome path
+
+
+
+%%
+# === Source Code Section ==
+# Hierarchy of folders and files
+# Use Tabulator to mark next level in hierarchy
+# All folders are nested into SourceHome path
+
+
+
+%%
+# ===== UI Section =======
+# Pairs of path to UI elements, use " -> " delimiter
+# First component is a path relative to SourceHome\ui folders
+# Second component is internal path inside project file
+
+
+
+%%
+# === References Section ===
+# List dependencies in one of the formats
+# global : GLOBAL_NAME
+# guid : {REGISTERED_GUID}
+# file : PATH_TO_LIBRARY

samples/s_Test_sample.cls

@@ -0,0 +1,31 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "s_Test_sample"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ===== Test suite sample =======
+Option Explicit
+
+Private parser_ As PC_ParserDate
+
+Public Function Setup()
+  ' Mandatory setup function
+  
+End Function
+
+Public Function Teardown()
+  ' Mandatory teardown function
+
+End Function
+
+Public Function t_TestName()
+  On Error GoTo PROPAGATE_ERROR
+
+  Exit Function
+PROPAGATE_ERROR:
+  Call Dev_LogError(Err.Number, Err.Description)
+End Function

samples/z_UIMessages_sample.bas

@@ -0,0 +1,71 @@
+Attribute VB_Name = "z_UIMessages_sample"
+' Ìîäóëü âûâîäà ñîîáùåíèé è âçàèìîäåéñòâèÿ ñ ïîëüçîâàòåëåì
+Option Private Module
+Option Explicit
+
+'# Êîäû ñîîáùåíèé
+Public Enum MsgCode
+  MSG_OK = 0
+  
+  'EM_DOC_NOT_ADDED
+  
+  'IM_SCAN_MODE
+  
+  '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 ProcessErrorMessages(expectedErrors As Scripting.Dictionary)
+  If Err.Number = 0 Then _
+    Exit Function
+    
+  ' Call Unload(CSE_ProgressBar)
+  If Not expectedErrors.Exists(Err.Number) Then _
+    Call Err.Raise(Err.Number)
+  
+  Select Case Err.Number
+'    Case EM_LINK_NO_FILE: Call UserInteraction.ShowMessage(Err.Number, Err.Source)
+  End Select
+End Function
+
+Public Function UIShowMessage(theCode As MsgCode, ParamArray params() As Variant)
+  Dim unwrapped As Variant: unwrapped = params
+  unwrapped = FixForwardedParams(unwrapped)
+  
+  Select Case theCode
+ ' Case EM_DOC_NOT_ADDED
+  '  Call MsgBox("Äîêóìåíò íå äîáàâëåí â Ðååñòð", vbExclamation)
+
+'  Case IM_SCAN_MODE
+ '   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("Âíèìàíèå! Â ïåðâûé àáçàö áóäåò äîáàâëåíà ñîîòâåòñòâóþùàÿ ññûëêà. Ïðîäîëæèòü?", vbYesNo + vbQuestion)
+    
+  Case Else
+    Call MsgBox("Íåâåðíûé êîä ñîîáùåíèÿ", vbCritical)
+  End Select
+  UIAskQuestion = answer = vbYes
+End Function

samples/z_UIRibbon_sample.bas

@@ -0,0 +1,15 @@
+Attribute VB_Name = "z_UIRibbon_sample"
+Option Private Module
+Option Explicit
+
+public Sub OnRibbonBtn(control As IRibbonControl)
+  Select Case control.ID
+    Case "GotoLinkBegin":       Call CC_GotoLinkBegin
+    Case "GotoLinkEnd":         Call CC_GotoLinkEnd
+    Case "WidthAdd10":         Call CC_WidthAdd10
+    Case "WidthSub10":         Call CC_WidthSub10
+    Case "TopAlignment":      Call CC_TopAlignment
+    Case "LeftAlignment":      Call CC_LeftAlignment
+    Case "ToggleInherited":    Call ToggleInherited
+  End Select
+End Sub

ui/CSE_ListSelector.frm

@@ -0,0 +1,198 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CSE_ListSelector 
+   Caption         =   "Âûáîð ñïèñêà çíà÷åíèé"
+   ClientHeight    =   8910.001
+   ClientLeft      =   45
+   ClientTop       =   375
+   ClientWidth     =   8400.001
+   OleObjectBlob   =   "CSE_ListSelector.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "CSE_ListSelector"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+' =========== List selection dialog ================
+' Shared module version: 20220703
+' Tested in:
+' Depends on: ex_MSHook
+' Required reference: Scripting
+Option Explicit
+Option Compare Text
+
+Private input_ As Excel.ListObject
+Private items_() As String
+Private selected_ As Scripting.Dictionary
+Private isUpdating_ As Boolean
+
+Public delimiter_ As String
+Public isCanceled_ As Boolean
+
+Private Sub UserForm_Initialize()
+  isUpdating_ = False
+  isCanceled_ = True
+  Call PositionInMiddle
+End Sub
+
+Private Sub UserForm_Finalize()
+  Call HookDisable
+End Sub
+
+Private Sub UserForm_Activate()
+  Call HookEnable(Me, "ProcessMouseWheelMovement")
+End Sub
+
+Private Sub UserForm_Deactivate()
+  Call HookDisable
+End Sub
+
+Public Function Init(iData As Excel.ListObject, Optional bAllowNewItems As Boolean = True)
+  Set input_ = iData
+  delimiter_ = TBDelim.Text
+  
+  Call ResetSelection
+  Call ScanInput
+  Call OnFilter("")
+  
+  TBNewItem.Enabled = bAllowNewItems
+  BtnAddItem.Enabled = bAllowNewItems
+End Function
+
+Public Function GetSelectedStr() As String
+  Dim sText$: sText = vbNullString
+  Dim vItem As Variant
+  For Each vItem In selected_.Keys
+    If sText <> vbNullString Then _
+      sText = sText & delimiter_
+    sText = sText & CStr(vItem)
+  Next vItem
+  GetSelectedStr = sText
+End Function
+
+' ========== Event handlers ==========
+Private Sub OkBtn_Click()
+  isCanceled_ = False
+  Call Me.Hide
+  Call HookDisable
+End Sub
+
+Private Sub CancelBtn_Click()
+  isCanceled_ = True
+  Call Me.Hide
+  Call HookDisable
+End Sub
+
+Private Sub ClearListBtn_Click()
+  Call ResetSelection
+  Call OnFilter(TBFilter.Text)
+End Sub
+
+Private Sub TBFilter_Change()
+  Call OnFilter(TBFilter.Text)
+End Sub
+
+Private Sub TBDelim_Change()
+  delimiter_ = TBDelim.Text
+End Sub
+
+Private Sub LBItems_Change()
+  If isUpdating_ Then _
+    Exit Sub
+    
+  Dim nItem&
+  For nItem = 0 To LBItems.ListCount - 1 Step 1
+    Dim sText$: sText = LBItems.List(nItem)
+    If LBItems.Selected(nItem) Then
+      If Not selected_.Exists(sText) Then _
+        Call selected_.Add(sText, 0)
+    Else
+      If selected_.Exists(sText) Then _
+        Call selected_.Remove(sText)
+    End If
+  Next nItem
+End Sub
+
+Private Sub BtnAddItem_Click()
+  Dim sNewItem$: sNewItem = TBNewItem.Text
+  If sNewItem = vbNullString Then _
+    Exit Sub
+  Dim nItem&
+  For nItem = LBound(items_) To UBound(items_) Step 1
+    If items_(nItem) = sNewItem Then
+      Call UserInteraction.ShowMessage(EM_ITEM_EXISTS, sNewItem)
+      Exit Sub
+    End If
+  Next nItem
+  
+  Dim iRow As Excel.ListRow: Set iRow = input_.ListRows.Add(1)
+  iRow.Range.Cells(1, 1) = sNewItem
+  Call ScanInput
+  Call OnFilter(TBFilter.Text)
+End Sub
+
+' ======= Mouse scrolling for listbox ========
+Public Function ProcessMouseWheelMovement(nDirection&)
+  If nDirection > 0 Then
+    If LBItems.TopIndex > 0 Then _
+      LBItems.TopIndex = LBItems.TopIndex - 1
+  Else
+    If LBItems.TopIndex < LBItems.ListCount - 1 Then _
+      LBItems.TopIndex = LBItems.TopIndex + 1
+  End If
+End Function
+
+' =========
+Private Function PositionInMiddle()
+  Dim nTopOffset&: nTopOffset = (Application.UsableHeight / 2) - (Me.Height / 2)
+  Dim nLeftOffset&: nLeftOffset = (Application.UsableWidth / 2) - (Me.Width / 2)
+  
+  Me.StartUpPosition = 0
+  Me.Top = Application.Top + IIf(nTopOffset > 0, nTopOffset, 0)
+  Me.Left = Application.Left + IIf(nLeftOffset > 0, nLeftOffset, 0)
+End Function
+
+Private Function ScanInput()
+  ReDim items_(1 To input_.Range.Rows.Count - 1)
+  Dim nRow&
+  For nRow = 2 To input_.Range.Rows.Count Step 1
+    items_(nRow - 1) = input_.Range.Cells(nRow, 1)
+  Next nRow
+End Function
+
+Private Function ResetSelection()
+  Set selected_ = New Scripting.Dictionary
+  selected_.CompareMode = TextCompare
+End Function
+
+Private Function OnFilter(sFilter$)
+  Call LBItems.Clear
+  Dim nItem&
+  For nItem = LBound(items_) To UBound(items_) Step 1
+    If sFilter = vbNullString Or VBA.InStr(1, items_(nItem), sFilter, vbTextCompare) <> 0 Then
+      Call LBItems.AddItem(items_(nItem))
+    End If
+  Next nItem
+  Call UpdateSelected
+  Call UpdateCount
+End Function
+
+Private Function UpdateCount()
+  TBViewCount.Value = LBItems.ListCount
+  TBTotalCount.Value = ArraySize(items_)
+  TBSelectedCount.Value = selected_.Count
+End Function
+
+Private Function UpdateSelected()
+  isUpdating_ = True
+  
+  If LBItems.ListCount = 0 Then _
+    Exit Function
+  
+  Dim nItem&
+  For nItem = 0 To LBItems.ListCount - 1 Step 1
+    LBItems.Selected(nItem) = selected_.Exists(LBItems.List(nItem))
+  Next nItem
+  
+  isUpdating_ = False
+End Function

ui/CSE_ProgressBar.frm

@@ -0,0 +1,329 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CSE_ProgressBar 
+   Caption         =   "Âûïîëíåíèå ïðîöåññà"
+   ClientHeight    =   2850
+   ClientLeft      =   45
+   ClientTop       =   330
+   ClientWidth     =   5280
+   OleObjectBlob   =   "CSE_ProgressBar.frx":0000
+   ShowModal       =   0   'False
+   StartUpPosition =   2  'CenterScreen
+End
+Attribute VB_Name = "CSE_ProgressBar"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+' =========== Progress Bar ================
+' Shared module version: 20210827
+' Tested in:
+' Depends on:
+' Required reference:
+Option Explicit
+
+Private thisWindow_&
+
+Private isInterrupted_ As Boolean
+Private canBeInterrupted_ As Boolean
+
+Private minA_&
+Private maxA_&
+Private valueA_&
+Private progressA_ As Double
+
+Private minB_&
+Private maxB_&
+Private valueB_&
+Private progressB_ As Double
+
+Private tStart_&
+
+Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
+
+'Windows API calls to remove the [x] from the top-right of the form
+Private Declare PtrSafe Function FindWindow Lib "user32" _
+  Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
+Private Declare PtrSafe Function GetWindowLong Lib "user32" _
+  Alias "GetWindowLongA" (ByVal nHwnd As Long, ByVal nIndex As Long) As Long
+Private Declare PtrSafe Function SetWindowLong Lib "user32" _
+  Alias "SetWindowLongA" (ByVal nHwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+
+'Windows API calls to bring the progress bar form to the front of other modeless forms
+Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As Long
+Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal nHwnd As Long, ByRef lpdwProcessId As Long) As Long
+Private Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal nHwnd As Long) As Long
+
+Private Const UDATE_RATE = 0.005 ' ×àñòîòà îáíîâëåíèÿ - êàæäûé 0.5%
+
+Private Sub UserForm_Initialize()
+  isInterrupted_ = False
+  canBeInterrupted_ = False
+  
+  minA_ = 0
+  maxA_ = 100
+  valueA_ = 50
+  progressA_ = 50
+  
+  Call Init("Çàãðóçêà...")
+  If Application.Name <> "Microsoft Visio" Then _
+    Call PositionInMiddle
+  Call RemoveCloseButton
+End Sub
+
+Public Function Init(sTitle$, _
+                      Optional sHeader$ = vbNullString, _
+                      Optional minVal& = 0, _
+                      Optional maxVal& = 100, _
+                      Optional curVal& = 0, _
+                      Optional canInterrupt As Boolean = False)
+  canBeInterrupted_ = canInterrupt
+  btnInterrupt.Visible = canInterrupt
+  isInterrupted_ = False
+  
+  If thisWindow_ = 0 Then
+    Me.Caption = "VBAProgressBar"
+    thisWindow_ = FindWindow(vbNullString, Me.Caption)
+  End If
+  
+  tStart_ = GetTickCount()
+
+  minA_ = minVal
+  maxA_ = maxVal
+  
+  minB_ = 0
+  maxB_ = 100
+  valueB_ = 0
+  
+  Call EnableSecondBar(False)
+  Me.Title = sTitle
+  Me.HeaderLbl.Caption = sHeader
+  Me.DescriptionTB.Text = vbNullString
+  
+  Call SetAInternal(curVal, bForceUpdate:=True)
+End Function
+
+Public Function InitSecondBar(Optional minVal& = 0, Optional maxVal& = 100, Optional curVal& = 0)
+  Call EnableSecondBar(True)
+  minB_ = minVal
+  maxB_ = maxVal
+  Call SetBInternal(curVal, bForceUpdate:=True)
+End Function
+
+Public Function ShowModeless()
+  Call UpdateBar
+  Call Me.Show(vbModeless)
+End Function
+
+Private Sub btnInterrupt_Click()
+  HeaderLbl.Caption = "Èíèöèèðîâàíà îòìåíà, îæèäàéòå..."
+  isInterrupted_ = True
+
+  btnInterrupt.Enabled = False
+  Call RepaintEx
+End Sub
+
+Private Sub UserForm_QueryClose(ByRef nCancelCode As Integer, ByRef nCloseMode As Integer)
+  If nCloseMode = vbFormControlMenu And canBeInterrupted_ Then _
+    nCancelCode = True
+End Sub
+
+' ====== Access =====
+Public Property Get Interrupted() As Boolean
+  Interrupted = isInterrupted_
+End Property
+
+Public Property Get Time() As Double
+  Time = GetTickCount() - tStart_
+End Property
+
+Public Property Get TimeStr() As String
+  TimeStr = Format(Time / 1000, "# ##0.##") & " ñåê"
+End Property
+
+Public Property Get Title() As String
+  Title = Me.Caption
+End Property
+
+Public Property Get Description() As String
+  Description = DescriptionTB.Text
+End Property
+
+Public Property Get Header() As String
+  Header = HeaderLbl.Caption
+End Property
+
+Public Property Get SecondBarEnabled() As Boolean
+  SecondBarEnabled = FrameSecBar.Visible
+End Property
+
+Public Property Get ValueA() As Long
+  ValueA = valueA_
+End Property
+
+Public Property Get MinA() As Long
+  MinA = minA_
+End Property
+
+Public Property Get MaxA() As Long
+  MaxA = maxA_
+End Property
+
+Public Property Get ProgressA() As Double
+  If maxA_ = minA_ Then
+    ProgressA = 100
+  Else
+    ProgressA = VBA.Abs((valueA_ - minA_) / (maxA_ - minA_))
+  End If
+End Property
+
+Public Property Get ValueB() As Long
+  ValueB = valueB_
+End Property
+
+Public Property Get MinB() As Long
+  MinB = minB_
+End Property
+
+Public Property Get MaxB() As Long
+  MaxB = maxB_
+End Property
+
+Public Property Get ProgressB() As Double
+  If maxB_ = minB_ Then
+    ProgressB = 100
+  Else
+    ProgressB = VBA.Abs((valueB_ - minB_) / (maxB_ - minB_))
+  End If
+End Property
+
+' ===== Modify =====
+Public Property Let Title(ByVal newVal$)
+  Me.Caption = newVal
+  Call RemoveCloseButton
+End Property
+
+Public Property Let Description(ByVal newVal$)
+  DescriptionTB.Text = newVal
+  Call RepaintEx
+End Property
+
+Public Property Let Header(ByVal newVal$)
+  HeaderLbl.Caption = newVal
+  Call RepaintEx
+End Property
+
+' ====== Actions ===
+Public Function IncrementA(Optional delta& = 1)
+  If Me.Visible Then _
+    Call SetAInternal(valueA_ + delta, bForceUpdate:=False)
+End Function
+
+Public Function IncrementB(Optional delta& = 1)
+  If Me.Visible Then _
+    Call SetBInternal(valueB_ + delta, bForceUpdate:=False)
+End Function
+
+Public Function HideSecondBar()
+  Call EnableSecondBar(False)
+End Function
+
+Public Function SetA(ByVal newVal&, Optional bForceUpdate As Boolean = False)
+  If Me.Visible Then _
+    Call SetAInternal(newVal, bForceUpdate)
+End Function
+
+Public Function SetB(ByVal newVal&, Optional bForceUpdate As Boolean = False)
+  If Me.Visible Then _
+    Call SetBInternal(newVal, bForceUpdate)
+End Function
+
+' =======
+Private Function EnableSecondBar(bEnable As Boolean)
+  FrameSecBar.Visible = bEnable
+  Call RepaintEx
+End Function
+
+Private Function PositionInMiddle()
+  Dim nTopOffset&: nTopOffset = (Application.UsableHeight / 2) - (Me.Height / 2)
+  Dim nLeftOffset&: nLeftOffset = (Application.UsableWidth / 2) - (Me.Width / 2)
+  
+  Me.StartUpPosition = 0
+  Me.Top = Application.Top + IIf(nTopOffset > 0, nTopOffset, 0)
+  Me.Left = Application.Left + IIf(nLeftOffset > 0, nLeftOffset, 0)
+End Function
+
+Private Function SetAInternal(ByVal newVal&, bForceUpdate As Boolean)
+  valueA_ = newVal
+  If valueA_ > maxA_ Then _
+    valueA_ = maxA_
+  If valueA_ < minA_ Then _
+    valueA_ = minA_
+  Call SetProgressA(Me.ProgressA, bForceUpdate)
+End Function
+
+Private Function SetBInternal(ByVal newVal&, bForceUpdate As Boolean)
+  valueB_ = newVal
+  If valueB_ > maxB_ Then _
+    valueB_ = maxB_
+  If valueB_ < minB_ Then _
+    valueB_ = minB_
+  Call SetProgressB(Me.ProgressB, bForceUpdate)
+End Function
+
+Private Function SetProgressA(newProgress As Double, bForceUpdate As Boolean)
+  If Not bForceUpdate And Abs(newProgress - progressA_) < UDATE_RATE Then _
+    Exit Function
+  
+  progressA_ = newProgress
+  Call UpdateTime
+  Call UpdateBar
+  Call RepaintEx
+End Function
+
+Private Function SetProgressB(newProgress As Double, bForceUpdate)
+  If Not bForceUpdate And Abs(newProgress - progressB_) < UDATE_RATE Then _
+    Exit Function
+    
+  progressB_ = newProgress
+  Call UpdateTime
+  Call UpdateBar
+  Call RepaintEx
+End Function
+
+Private Function UpdateBar()
+  fraInside.Width = VBA.Int(lblBack.Width * progressA_)
+  lblSecBar.Width = VBA.Int(FrameSecBar.Width * progressB_)
+
+  lblBack.Caption = Format(progressA_, "0%")
+  lblFront.Caption = Format(progressA_, "0%")
+End Function
+
+Private Function RemoveCloseButton()
+  Const WS_SYSMENU& = &H80000
+  Const GWL_STYLE& = (-16)
+  Dim lStyle&: lStyle = GetWindowLong(thisWindow_, GWL_STYLE)
+  If lStyle And WS_SYSMENU > 0 Then _
+    Call SetWindowLong(thisWindow_, GWL_STYLE, (lStyle And Not WS_SYSMENU))
+End Function
+
+Private Function BringToFront()
+  Dim lFocusThread&: lFocusThread = GetWindowThreadProcessId(GetForegroundWindow(), 0)
+  Dim lThisThread&: lThisThread = GetWindowThreadProcessId(thisWindow_, 0)
+  If lFocusThread = lThisThread Then
+    Call SetForegroundWindow(thisWindow_)
+  Else
+    DoEvents
+  End If
+End Function
+
+Private Function UpdateTime()
+  TimeLabel.Caption = "Äëèòåëüíîñòü: " & TimeStr()
+End Function
+
+Private Function RepaintEx()
+  If Me.Visible Then
+    Call Me.Repaint
+    ' BringToFront ' Ðàñêîììåíòèðîâàòü, ÷òîáû îêíî ñàìî âñïëûâàëî ïðè êàæäîì îáíîâëåíèè (óæàñíî áåñèò â ôîíîâîì ðåæèìå)
+  End If
+  DoEvents
+End Function

ui/Calendar/CSE_Calendar.frm

@@ -0,0 +1,483 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CSE_Calendar 
+   Caption         =   "Calendar"
+   ClientHeight    =   4455
+   ClientLeft      =   30
+   ClientTop       =   390
+   ClientWidth     =   4440
+   OleObjectBlob   =   "CSE_Calendar.frx":0000
+   StartUpPosition =   2  'CenterScreen
+End
+Attribute VB_Name = "CSE_Calendar"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+' =========== Calendar picker native VBA ================
+' Shared module version: 20210502
+' Dependencies: z_CalendarUI, CSE_CallbackCalendar
+Option Explicit
+
+Private Const GWL_STYLE = -16
+Private Const WS_CAPTION = &HC00000
+Private Const MOUSE_LEFT_BTN = 1
+
+Private Const CALENDAR_DAYS_COUNT = 42
+Private Const CALENDAR_WEEKDAY_COUNT = 7
+Private Const CALENDAR_MONTH_COUNT = 12
+
+Private Const CALENDAR_YEARS_PER_PAGE = 12
+
+Private Type CalendarThemeColors
+  background_ As Long
+  foreground_ As Long
+  curDateBG_ As Long
+  curDateFG_ As Long
+  inactiveDates_ As Long
+End Type
+
+Private Enum CalendarMode
+  CAL_MODE_DAY = 0
+  CAL_MODE_MONTH = 1
+  CAL_MODE_YEAR = 2
+End Enum
+
+Private Declare PtrSafe Function FindWindow Lib "user32" _
+  Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
+Private Declare PtrSafe Function GetWindowLong Lib "user32" _
+  Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
+Private Declare PtrSafe Function SetWindowLong Lib "user32" _
+  Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+
+Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
+
+Public isCancelled_ As Boolean
+
+Private curDate_ As Long
+
+Private month_ As Long
+Private year_ As Long
+
+Private mode_ As CalendarMode
+Private theme_ As TCalendarTheme
+Private colors_ As CalendarThemeColors
+
+Private firstYear_ As Long
+Private lastYear_ As Long
+
+Private xPos_ As Double
+Private yPos_ As Double
+
+Private callbacks_ As Collection
+
+Private Sub UserForm_Initialize()
+  Call ResetBorders
+  Call HideTitleBar
+  Call InitLabelCallbacks
+  
+  isCancelled_ = True
+  mode_ = CAL_MODE_DAY
+
+  Call PositionInMiddle
+  Call SetCurrentDateInternal(Int(Now))
+  Call SetTheme(T_CT_LIGHT)
+End Sub
+
+Public Function Init(theDate&, aTheme As TCalendarTheme)
+  isCancelled_ = True
+  
+  Call SetCurrentDateInternal(theDate)
+  Call ChangeMode(CAL_MODE_DAY)
+  Call UpdateTitle
+  Call SetTheme(aTheme)
+  Call ResetBorders
+End Function
+
+Public Property Get SelectedDate() As Long
+  SelectedDate = curDate_
+End Property
+
+Public Property Get Theme() As TCalendarTheme
+  Theme = theme_
+End Property
+
+Public Function SetTheme(newValue As TCalendarTheme)
+  theme_ = newValue
+  Call UpdateThemeColors
+  Call RepaintAllColors
+End Function
+
+' ==== Events handlings ======
+Public Function OnDayClicked(cLabel As MSForms.Label)
+  Call ReturnResult(cLabel.Tag)
+End Function
+
+Public Function OnMonthClicked(cLabel As MSForms.Label)
+  month_ = TagToMonth(cLabel.Caption)
+  Call ChangeMode(CAL_MODE_DAY)
+End Function
+
+Public Function OnYearClicked(cLabel As MSForms.Label)
+  If Len(Trim(cLabel.Caption)) = 0 Then _
+    Exit Function
+  year_ = val(cLabel.Caption)
+  Call ChangeMode(CAL_MODE_MONTH)
+End Function
+
+Private Sub lblToday_Click()
+  If mode_ <> CAL_MODE_DAY Then
+    Call SetCurrentDateInternal(Int(Now))
+    Call ChangeMode(CAL_MODE_DAY)
+  Else
+    Call ReturnResult(Int(Now))
+  End If
+End Sub
+
+Private Sub lblThemes_Click()
+  If theme_ < TCalendarTheme.[_Last] Then
+    Call SetTheme(theme_ + 1)
+  Else
+    Call SetTheme(TCalendarTheme.[_First])
+  End If
+End Sub
+
+Private Sub lblUnload_Click()
+  isCancelled_ = True
+  Call Me.Hide
+End Sub
+
+Private Sub btnClose_Click()
+  If mode_ <> CAL_MODE_DAY Then
+    Call ChangeMode(mode_ - 1)
+  Else
+    isCancelled_ = True
+    Call Me.Hide
+  End If
+End Sub
+
+Private Sub lblUP_Click()
+  Select Case mode_
+    Case CAL_MODE_DAY
+      Call IncrementMonth(-1)
+      
+    Case CAL_MODE_MONTH
+    
+    Case CAL_MODE_YEAR
+      lastYear_ = firstYear_ - 1
+      firstYear_ = firstYear_ - CALENDAR_YEARS_PER_PAGE
+      Call RepaintYearsColor
+  End Select
+End Sub
+
+Private Sub lblDOWN_Click()
+  Select Case mode_
+    Case CAL_MODE_DAY
+      Call IncrementMonth(1)
+    
+    Case CAL_MODE_MONTH
+    
+    Case CAL_MODE_YEAR
+      firstYear_ = lastYear_ + 1
+      lastYear_ = lastYear_ + CALENDAR_YEARS_PER_PAGE
+      Call RepaintYearsColor
+  End Select
+End Sub
+
+Private Sub UserForm_MouseDown(ByVal nBtn As Integer, ByVal nShift As Integer, ByVal mvX As Single, ByVal mvY As Single)
+  If nBtn = MOUSE_LEFT_BTN Then
+    xPos_ = mvX
+    yPos_ = mvY
+  End If
+End Sub
+
+Private Sub UserForm_MouseMove(ByVal nBtn As Integer, ByVal nShift As Integer, ByVal mvX As Single, ByVal mvY As Single)
+  If nBtn And MOUSE_LEFT_BTN Then
+    Me.Left = Me.Left + (mvX - xPos_)
+    Me.Top = Me.Top + (mvY - yPos_)
+  End If
+End Sub
+
+Private Sub Frame1_MouseDown(ByVal nBtn As Integer, ByVal nShift As Integer, ByVal mvX As Single, ByVal mvY As Single)
+  If nBtn = MOUSE_LEFT_BTN Then
+    xPos_ = mvX
+    yPos_ = mvY
+  End If
+End Sub
+
+Private Sub lblTitleCurMY_Click()
+'--> Handles the month to year multipage display
+  If mode_ = CAL_MODE_YEAR Then _
+    Exit Sub
+  Call ChangeMode(mode_ + 1)
+End Sub
+
+' =========
+Private Function ReturnResult(theDate&)
+  curDate_ = theDate
+  isCancelled_ = False
+  Call Me.Hide
+End Function
+
+Private Function PositionInMiddle()
+  Dim nTopOffset&: nTopOffset = (Application.UsableHeight / 2) - (Me.Height / 2)
+  Dim nLeftOffset&: nLeftOffset = (Application.UsableWidth / 2) - (Me.Width / 2)
+  
+  Me.StartUpPosition = 0
+  Me.Top = Application.Top + IIf(nTopOffset > 0, nTopOffset, 0)
+  Me.Left = Application.Left + IIf(nLeftOffset > 0, nLeftOffset, 0)
+End Function
+
+Private Function HideTitleBar()
+  Dim frameHandle As Long: frameHandle = FindWindow(vbNullString, Me.Caption)
+  Dim windowHandle As Long: windowHandle = GetWindowLong(frameHandle, GWL_STYLE)
+  windowHandle = windowHandle And (Not WS_CAPTION)
+  Call SetWindowLong(frameHandle, GWL_STYLE, windowHandle)
+  Call DrawMenuBar(frameHandle)
+End Function
+
+Private Function ResetBorders()
+  Dim aLabel As control
+  For Each aLabel In Me.Controls
+    If TypeOf aLabel Is MSForms.Label Then _
+      aLabel.BorderStyle = fmBorderStyleNone
+  Next
+End Function
+
+Private Function InitLabelCallbacks()
+  Dim aControl As control
+  Dim controlType$
+  Set callbacks_ = New Collection
+  For Each aControl In Me.Controls
+    If Not TypeOf aControl Is MSForms.Label Then _
+      GoTo NEXT_CONTROL
+    controlType = Left(aControl.Name, 1)
+    If Not controlType Like "[DMY]" Then _
+      GoTo NEXT_CONTROL
+    Call AddCallback(aControl)
+NEXT_CONTROL:
+  Next aControl
+  
+  Call AddCallback(lblUP)
+  Call AddCallback(lblDOWN)
+  Call AddCallback(lblThemes)
+  Call AddCallback(lblUnload)
+  Call AddCallback(lblTitleCurMY, bUnderline:=True)
+  Call AddCallback(lblToday, bUnderline:=True)
+End Function
+
+Private Function AddCallback(target As control, Optional bUnderline As Boolean = False)
+  Dim newCallback As New CSE_CallbackCalendar
+  Call newCallback.Init(target, bUnderline)
+  Call callbacks_.Add(newCallback)
+End Function
+
+Private Function SetCurrentDateInternal(theDate&)
+  curDate_ = theDate
+  month_ = Month(curDate_)
+  year_ = Year(curDate_)
+  Call UpdateDays
+End Function
+
+Private Function IncrementMonth(inc&)
+  year_ = year_ + ((month_ + inc + CALENDAR_MONTH_COUNT - 1) \ CALENDAR_MONTH_COUNT - 1)
+  month_ = 1 + ((CALENDAR_MONTH_COUNT + (month_ + inc - 1) Mod CALENDAR_MONTH_COUNT) Mod CALENDAR_MONTH_COUNT)
+  Call UpdateTitle
+  Call UpdateDays
+End Function
+
+Private Function ChangeMode(newMode As CalendarMode)
+  If newMode = mode_ Then _
+    Exit Function
+  
+  Me.MPmainDisplay.Value = newMode
+  Call SetArrowsVisibility(newMode <> CAL_MODE_MONTH)
+  mode_ = newMode
+  Select Case mode_
+    Case CAL_MODE_DAY
+      Call UpdateDays
+  
+    Case CAL_MODE_MONTH
+      Call RepaintMonthsColors
+
+    Case CAL_MODE_YEAR
+      lastYear_ = year_ + 1
+      firstYear_ = lastYear_ - CALENDAR_YEARS_PER_PAGE + 1
+      Call RepaintYearsColor
+  End Select
+  Call UpdateTitle
+End Function
+
+Private Function UpdateDays()
+'--> Populate the calendar
+  Dim firstDay&: firstDay = DateSerial(year_, month_, 1)
+  firstDay = firstDay - Weekday(firstDay, vbMonday) + 1
+  Dim lastDay&: lastDay = firstDay + CALENDAR_DAYS_COUNT - 1
+  
+  Dim nItem&
+  For nItem = 1 To CALENDAR_DAYS_COUNT
+    With Me.Controls("D" & nItem)
+      .Caption = Day(firstDay + nItem - 1)
+      .Tag = firstDay + nItem - 1
+    End With
+  Next nItem
+  
+  Call RepaintDaysColors
+End Function
+
+Private Function UpdateTitle()
+  Select Case mode_
+    Case CAL_MODE_DAY
+      lblTitleCurMY.Caption = Format(DateSerial(year_, month_, 1), "MMMM yyyy")
+  
+    Case CAL_MODE_MONTH
+      lblTitleCurMY.Caption = year_
+
+    Case CAL_MODE_YEAR
+      lblTitleCurMY.Caption = firstYear_ & " - " & lastYear_
+  End Select
+End Function
+
+Private Function UpdateThemeColors()
+  With colors_
+    Select Case theme_
+      Case TCalendarTheme.T_CT_DARK
+        .background_ = RGB(69, 69, 69)
+        .foreground_ = RGB(252, 248, 248)
+        .curDateBG_ = RGB(246, 127, 8)
+        .curDateFG_ = RGB(0, 0, 0)
+        .inactiveDates_ = RGB(120, 120, 120)
+    
+      Case TCalendarTheme.T_CT_RED
+        .background_ = RGB(87, 0, 0)
+        .foreground_ = RGB(203, 146, 146)
+        .curDateBG_ = RGB(122, 185, 247)
+        .curDateFG_ = RGB(0, 0, 0)
+        .inactiveDates_ = RGB(144, 70, 70)
+    
+      Case TCalendarTheme.T_CT_BLUE
+        .background_ = RGB(42, 48, 92)
+        .foreground_ = RGB(179, 179, 179)
+        .curDateBG_ = RGB(122, 185, 247)
+        .curDateFG_ = RGB(0, 0, 0)
+        .inactiveDates_ = RGB(80, 80, 166)
+    
+      Case TCalendarTheme.T_CT_LIGHT
+        .background_ = RGB(240, 240, 240)
+        .foreground_ = RGB(0, 0, 0)
+        .curDateBG_ = RGB(246, 127, 8)
+        .curDateFG_ = RGB(0, 0, 0)
+        .inactiveDates_ = RGB(200, 200, 200)
+    End Select
+  End With
+End Function
+
+Private Function SetArrowsVisibility(isVisible As Boolean)
+  lblDOWN.Visible = isVisible
+  lblUP.Visible = isVisible
+End Function
+
+Private Function TagToMonth(sTag$) As Long
+  Select Case sTag
+    Case "JAN": TagToMonth = 1
+    Case "FEB": TagToMonth = 2
+    Case "MAR": TagToMonth = 3
+    Case "APR": TagToMonth = 4
+    Case "MAY": TagToMonth = 5
+    Case "JUN": TagToMonth = 6
+    Case "JUL": TagToMonth = 7
+    Case "AUG": TagToMonth = 8
+    Case "SEP": TagToMonth = 9
+    Case "OCT": TagToMonth = 10
+    Case "NOV": TagToMonth = 11
+    Case "DEC": TagToMonth = 12
+  End Select
+End Function
+
+Private Function RepaintAllColors()
+  Me.BackColor = colors_.background_
+  FrameDay.BackColor = colors_.background_
+  FrameMonth.BackColor = colors_.background_
+  FrameYr.BackColor = colors_.background_
+  
+  lblToday.ForeColor = colors_.foreground_
+  lblToday.BorderColor = colors_.foreground_
+  
+  lblTitleCurMY.ForeColor = colors_.foreground_
+  lblTitleCurMY.BorderColor = colors_.foreground_
+
+  lblUnload.ForeColor = colors_.foreground_
+  lblThemes.ForeColor = colors_.foreground_
+
+  lblUP.ForeColor = colors_.foreground_
+  lblDOWN.ForeColor = colors_.foreground_
+  
+  Dim nItem&
+  For nItem = 1 To CALENDAR_WEEKDAY_COUNT Step 1
+    Me.Controls("WD" & nItem).ForeColor = colors_.foreground_
+  Next nItem
+  
+  Call RepaintDaysColors
+  Call RepaintMonthsColors
+  Call RepaintYearsColor
+End Function
+
+Private Function RepaintDaysColors()
+  Dim nItem&
+  Dim theDate&
+  For nItem = 1 To CALENDAR_DAYS_COUNT Step 1
+    With Me.Controls("D" & nItem)
+      theDate = .Tag
+      .BorderStyle = fmBorderStyleNone
+      If .Tag = curDate_ Then
+        .BackStyle = fmBackStyleOpaque
+        .BackColor = colors_.curDateBG_
+        .ForeColor = colors_.curDateFG_
+      ElseIf Month(.Tag) = month_ Then
+        .BackStyle = fmBackStyleTransparent
+        .BackColor = colors_.background_
+        .ForeColor = colors_.foreground_
+      Else
+        .BackStyle = fmBackStyleTransparent
+        .BackColor = colors_.background_
+        .ForeColor = colors_.inactiveDates_
+      End If
+    End With
+  Next nItem
+End Function
+
+Private Function RepaintMonthsColors()
+  Dim nMonth&
+  For nMonth = 1 To CALENDAR_MONTH_COUNT Step 1
+    With Me.Controls("M" & nMonth)
+      .BorderStyle = fmBorderStyleNone
+      If nMonth = month_ Then
+        .BackStyle = fmBackStyleOpaque
+        .BackColor = colors_.curDateBG_
+        .ForeColor = colors_.curDateFG_
+      Else
+        .BackStyle = fmBackStyleTransparent
+        .BackColor = colors_.background_
+        .ForeColor = colors_.foreground_
+      End If
+    End With
+  Next nMonth
+End Function
+
+Private Function RepaintYearsColor()
+  Dim nYear&
+  For nYear = 1 To CALENDAR_YEARS_PER_PAGE Step 1
+    With Me.Controls("Y" & nYear)
+      .BorderStyle = fmBorderStyleNone
+      .Caption = CStr(firstYear_ + nYear - 1)
+      If nYear + firstYear_ - 1 = year_ Then
+        .BackStyle = fmBackStyleOpaque
+        .BackColor = colors_.curDateBG_
+        .ForeColor = colors_.curDateFG_
+      Else
+        .BackStyle = fmBackStyleTransparent
+        .BackColor = colors_.background_
+        .ForeColor = colors_.foreground_
+      End If
+    End With
+  Next nYear
+End Function

ui/Calendar/CSE_CallbackCalendar.cls

@@ -0,0 +1,53 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "CSE_CallbackCalendar"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' =========== Calendar picker native VBA - Label clicks callback ================
+' Shared module version: 20210130
+' Dependencies: z_CalendarUI, CSE_Calendar
+Option Explicit
+
+Private Const CAL_MOVE_MARGIN = 2
+
+Public WithEvents control_ As MSForms.Label
+Attribute control_.VB_VarHelpID = -1
+
+Private underline_ As Boolean
+
+Public Function Init(aControl As MSForms.Label, Optional bUnderline As Boolean = False)
+  Set control_ = aControl
+  underline_ = bUnderline
+End Function
+
+Private Sub control__Click()
+  Dim controlType$: controlType = Left(control_.Name, 1)
+  Select Case controlType
+    Case "D": Call CSE_Calendar.OnDayClicked(control_)
+    Case "M": Call CSE_Calendar.OnMonthClicked(control_)
+    Case "Y": Call CSE_Calendar.OnYearClicked(control_)
+  End Select
+End Sub
+
+Private Sub control__MouseMove(ByVal nBtn As Integer, ByVal nShift As Integer, ByVal mvX As Single, ByVal mvY As Single)
+  Dim bIsOutside As Boolean: bIsOutside = IsMoveOutside(mvX, mvY)
+  If underline_ Then
+    control_.Font.Underline = Not bIsOutside
+    control_.Font.Bold = Not bIsOutside
+  Else
+    control_.BorderStyle = IIf(bIsOutside, fmBorderStyleNone, fmBorderStyleSingle)
+  End If
+End Sub
+
+' =======
+Private Function IsMoveOutside(mvX As Single, mvY As Single)
+  IsMoveOutside = _
+    mvX >= control_.Width - CAL_MOVE_MARGIN Or _
+    mvX <= CAL_MOVE_MARGIN Or _
+    mvY <= CAL_MOVE_MARGIN Or _
+    mvY >= control_.Height - CAL_MOVE_MARGIN
+End Function

ui/Calendar/z_CalendarUI.bas

@@ -0,0 +1,49 @@
+Attribute VB_Name = "z_CalendarUI"
+' =========== Calendar picker native VBA ================
+' Shared module version: 20210123
+' Dependencies: CSE_Calendar, CSE_CallbackCalendar
+Option Private Module
+Option Explicit
+
+Public Enum TCalendarTheme
+  T_CT_INVALID = 0
+  [_First] = 1
+  
+  T_CT_DARK = 1
+  T_CT_RED = 2
+  T_CT_BLUE = 3
+  T_CT_LIGHT = 4
+  
+  [_Last] = 4
+End Enum
+
+Public Function PromptDate(initDate&, Optional ByRef cTheme As TCalendarTheme = T_CT_DARK) As Long
+  With CSE_Calendar
+    Call .Init(initDate, cTheme)
+    Call .Show
+    If .isCancelled_ Then _
+      Exit Function
+    PromptDate = .SelectedDate
+    cTheme = .Theme
+  End With
+End Function
+
+Public Function CalendarTheme2String(eTheme As TCalendarTheme) As String
+  Select Case eTheme
+    Case T_CT_DARK: CalendarTheme2String = "DARK"
+    Case T_CT_RED: CalendarTheme2String = "RED"
+    Case T_CT_BLUE: CalendarTheme2String = "BLUE"
+    Case T_CT_LIGHT: CalendarTheme2String = "LIGHT"
+    Case Else: CalendarTheme2String = "INVALID"
+  End Select
+End Function
+
+Public Function String2CalendarTheme(sTheme$) As TCalendarTheme
+  Select Case sTheme
+    Case "DARK": String2CalendarTheme = T_CT_DARK
+    Case "RED": String2CalendarTheme = T_CT_RED
+    Case "BLUE": String2CalendarTheme = T_CT_BLUE
+    Case "LIGHT": String2CalendarTheme = T_CT_LIGHT
+    Case Else: String2CalendarTheme = T_CT_INVALID
+  End Select
+End Function

ui/ribbonVSO/.rels

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

ui/ribbonVSO/customUI1.xml

@@ -0,0 +1,16 @@
+<?xml version="1.0" encoding="utf-8"?>
+<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
+	<ribbon>
+	<tabs>
+	<tab id="ReestrNPA" label="РЕЕСТР НПА" >
+	<group id="HT03_Data" label="Действия со схемой" >
+		<button id="CreateSchema" size="large"
+				label="Генерировать схему"
+				supertip="Создать схему из данных Реестра"
+				onAction="OnAction"
+				imageMso="MindMapImportData"/>
+	</group>
+	</tab>
+	</tabs>
+	</ribbon>
+</customUI>

ui/ribbonWord/.rels

@@ -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="word/document.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>

ui/ribbonWord/customUI.xml

@@ -0,0 +1,16 @@
+<?xml version="1.0" encoding="utf-8"?>
+<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
+	<ribbon>
+	<tabs>
+	<tab id="TabID" label="Tab Title" >
+	<group id="GroupID" label="Ссылки" >
+		<button id="NextLink" size="large" keytip="W" 
+			label="Следующая ссылка"
+			supertip="Перейти к следующей необработанной ссылке [Ctrl+Shift+W]"
+			imageMso="PivotTableGroupSelection"
+			onAction="OnAction"/>
+	</group>
+	</tab>
+	</tabs>
+	</ribbon>
+</customUI>

ui/ribbonXL/.rels

@@ -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>

ui/ribbonXL/customUI.xml

@@ -0,0 +1,16 @@
+<?xml version="1.0" encoding="utf-8"?>
+<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
+	<ribbon>
+	<tabs>
+	<tab id="HT03_NPA" label="РЕЕСТР НПА" >
+	<group id="Group1" label="Функционал Excel модуля" >
+		<button id="HT03_NextDoc" visible="true" size="large" 
+			  label="Следющий документ"
+			  supertip="Следующий необработанный документ" 
+			  imageMso="PivotTableGroupSelection"
+			  onAction="OnAction"/>
+	</group>
+	</tab>
+	</tabs>
+	</ribbon>
+</customUI>

utility/API_Config.cls

@@ -0,0 +1,103 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_Config"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ================ Ðàáîòà êîíôèãóðàöèÿìè =============
+' Shared module version: 20220727
+' Tested in: TestCommons
+' Depends on: API_JSON
+' Required reference: Scripting, API_JSON
+Option Explicit
+
+Private Const JSON_IDENT_SIZE_SPACES = 4
+
+Private data_ As Scripting.Dictionary
+
+Private Sub Class_Initialize()
+  Call Clear
+End Sub
+
+Public Function Contains(sKey$) As Boolean
+  Contains = data_.Exists(sKey)
+End Function
+
+Public Function GetValue(sKey$, Optional iDefault As Variant = vbNullString) As Variant
+  If Not Contains(sKey) Then _
+    GoTo RETURN_DEFAULT
+    
+  If VBA.VarType(data_(sKey)) = vbObject Then
+    Set GetValue = data_(sKey)
+    Exit Function
+  Else
+    GetValue = data_(sKey)
+    If GetValue <> "" Then _
+      Exit Function
+  End If
+  
+RETURN_DEFAULT:
+  If VBA.VarType(iDefault) = vbObject Then
+    Set GetValue = iDefault
+  Else
+    GetValue = iDefault
+  End If
+End Function
+
+Public Function SetValue(sKey$, newVal As Variant)
+  If VBA.VarType(newVal) = vbObject Then
+    Set data_.Item(sKey) = newVal
+  Else
+    data_.Item(sKey) = newVal
+  End If
+End Function
+
+Public Function RemoveKey(sKey$)
+  If data_.Exists(sKey) Then _
+    Call data_.Remove(sKey)
+End Function
+
+Public Function Clear()
+  Set data_ = New Scripting.Dictionary
+End Function
+
+' Scan configuration from JSON file
+' Requires: sFile - path to valid UTF-8 JSON file
+Public Function LoadFromFile(sFile$) As Boolean
+  Dim iParser As New API_JSON
+  Dim newData As Object: Set newData = iParser.LoadFromFile(sFile)
+  LoadFromFile = Not newData Is Nothing
+  If LoadFromFile Then _
+    Set data_ = newData
+End Function
+
+' Scan configuration from JSON string
+Public Function LoadFromJSON(sJson$) As Boolean
+  LoadFromJSON = False
+  
+  Dim iParser As New API_JSON
+  On Error GoTo RETURN_FALSE
+  Set data_ = iParser.Parse(sJson)
+  
+  LoadFromJSON = True
+  
+RETURN_FALSE:
+  On Error GoTo 0
+End Function
+
+Public Function SaveToFile(sFile$, Optional bMultiline As Boolean = True) As Boolean
+  Dim iParser As New API_JSON
+  If bMultiline Then _
+    Call iParser.SetupMultiline(JSON_IDENT_SIZE_SPACES)
+  SaveToFile = iParser.SaveToFile(sFile, data_)
+End Function
+
+Public Function SaveToJSON(Optional bMultiline As Boolean = False) As String
+  Dim iParser As New API_JSON
+  If bMultiline Then _
+    Call iParser.SetupMultiline(JSON_IDENT_SIZE_SPACES)
+  SaveToJSON = iParser.CreateJSON(data_)
+End Function

utility/API_DistrManifest.cls

@@ -0,0 +1,73 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_DistrManifest"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ======== Products distribution manifest ========
+' Shared module version: 20220814
+' Tested in:
+' Depends on: API_JSON
+' Required reference: Scripting, ex_Version
+Option Explicit
+
+Private Const MANIFEST_JSON_IDENT = 4
+
+Public data_ As Scripting.Dictionary
+Private parser_ As New API_JSON
+Private file_ As String
+
+Private Sub Class_Initialize()
+  Call parser_.SetupMultiline(MANIFEST_JSON_IDENT)
+End Sub
+
+Public Function LoadFrom(sFile$)
+  file_ = sFile
+  Set data_ = parser_.LoadFromFile(file_)
+  If data_ Is Nothing Then _
+    Set data_ = New Scripting.Dictionary
+End Function
+
+Public Function LoadServer()
+  Call LoadFrom(CP_TOOLS_SERVER & "\" & FILE_DISTRIBUTION_MANIFEST)
+End Function
+
+Public Function LoadLocal()
+  Call LoadFrom(CP_TOOLS_LOCAL & "\" & FILE_DISTRIBUTION_MANIFEST)
+End Function
+
+Public Function IsLoaded() As Boolean
+  IsLoaded = False
+  
+  If data_ Is Nothing Then _
+    Exit Function
+  If data_.Count = 0 Then _
+    Exit Function
+    
+  IsLoaded = True
+End Function
+
+Public Function Reload()
+  Call LoadFrom(file_)
+End Function
+
+Public Function SetVersion(sProduct$, sVersion$)
+  data_(sProduct) = sVersion
+End Function
+
+Public Function GetVersion(sProduct$) As String
+  If Not data_.Exists(sProduct) Then _
+    Exit Function
+  GetVersion = data_(sProduct)
+End Function
+
+Public Function Save() As Boolean
+  Save = SaveTo(file_)
+End Function
+
+Public Function SaveTo(sFile$) As Boolean
+  SaveTo = parser_.SaveToFile(sFile, data_)
+End Function

utility/API_GraphOrdering.cls

@@ -0,0 +1,360 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_GraphOrdering"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ======= Graph sorting and ordering facilities =====
+' Shared module version: 20210422
+' Tested in: TestCommons
+' Depends on: ex_Collection, CDS_Graph, API_LinkedComponents
+' Required reference: Scripting
+Option Explicit
+ 
+Private graph_ As CDS_Graph
+Private nodes_ As Collection
+Private sourceOrder_ As Scripting.Dictionary ' Map of (nodeID, globalIndex)
+Private nodeComponents_ As Scripting.Dictionary ' Map of (nodeID, componentIndex)
+Private componentCount_ As Long
+
+Private status_ As Scripting.Dictionary
+Private ranks_ As Scripting.Dictionary
+
+Private Const MAX_NODE_INDEX& = 100000
+Private Const RANK_UNDEF = -1
+
+Private Enum TVisitStatus
+  T_STATUS_UNVISITED = 0
+  T_STATUS_VISITING = 1
+  T_STATUS_VISITED = 2
+End Enum
+
+Public Function Init(iGraph As CDS_Graph)
+  Call SetGraph(iGraph)
+End Function
+
+' Classic topological order (no edges pointing backward in order)
+Public Function TopologicalOrder() As Collection
+  Set sourceOrder_ = Nothing
+  Set TopologicalOrder = RevertCollection(DefaultOrder)
+End Function
+
+' Reversed topological order
+Public Function ReverseTopologicalOrder() As Collection
+  Set sourceOrder_ = Nothing
+  Set ReverseTopologicalOrder = DefaultOrder
+End Function
+
+' Topological order where linked components are grouped together
+Public Function TopologicalComponentOrder() As Collection
+  Set sourceOrder_ = Nothing
+  Dim iOrder As Collection: Set iOrder = RevertCollection(DefaultOrder)
+  Set TopologicalComponentOrder = GroupNodesDefault(iOrder)
+End Function
+
+' Reversed topological order where linked components are grouped together
+Public Function ReverseTopologicalComponentOrder() As Collection
+  Set sourceOrder_ = Nothing
+  Dim iOrder As Collection: Set iOrder = DefaultOrder
+  Set ReverseTopologicalComponentOrder = GroupNodesDefault(iOrder)
+End Function
+
+' Sort topologically using BFS and ordering according to input
+' Note: elements not present in the graph are excluded from output
+Public Function SortLayers(iSourceOrder As Collection) As Collection
+  If iSourceOrder.Count = 0 Then
+    Set SortLayers = New Collection
+    Exit Function
+  End If
+  
+  Call InitSourceOrder(iSourceOrder)
+  Dim iNodesOrder As Collection: Set iNodesOrder = InduceWidthOrder
+  Dim iComponents As Collection: Set iComponents = SortComponents(iNodesOrder)
+  Set SortLayers = GroupNodesInduced(iNodesOrder, iComponents)
+End Function
+
+' Sort topologically using DFS and ordering according to input
+' Note: elements not present in the graph are excluded from output
+Public Function SortDeep(iSourceOrder As Collection) As Collection
+  If iSourceOrder.Count = 0 Then
+    Set SortDeep = New Collection
+    Exit Function
+  End If
+  
+  Call InitSourceOrder(iSourceOrder)
+  Dim iNodesOrder As Collection: Set iNodesOrder = InduceDepthOrder
+  Dim iComponents As Collection: Set iComponents = SortComponents(iNodesOrder)
+  Set SortDeep = GroupNodesInduced(iNodesOrder, iComponents)
+End Function
+
+' ==============
+Private Function SetGraph(iGraph As CDS_Graph)
+  Set graph_ = iGraph
+  Set nodes_ = graph_.Nodes
+  Dim iProcessor As New API_LinkedComponents
+  Set nodeComponents_ = iProcessor.GetComponents(graph_)
+  componentCount_ = iProcessor.CountComponents
+End Function
+
+Private Function DefaultOrder()
+  Dim iOrder As New Collection
+  
+  Call InitStatus
+  
+  Dim iStack As Collection
+  Dim vNode As Variant
+  For Each vNode In nodes_
+    If status_(vNode) <> T_STATUS_UNVISITED Then _
+      GoTo NEXT_NODE
+    Set iStack = New Collection: Call iStack.Add(vNode)
+    Do While iStack.Count > 0
+      Dim vItem As Variant: vItem = iStack.Item(iStack.Count)
+      If status_(vItem) = T_STATUS_UNVISITED Then
+        status_(vItem) = T_STATUS_VISITING
+        Dim vChild As Variant
+        For Each vChild In graph_.nodes_(vItem).outputs_
+          If status_(vChild) = T_STATUS_UNVISITED Then _
+            Call iStack.Add(vChild)
+        Next vChild
+      Else
+        Call iStack.Remove(iStack.Count)
+        If status_(vItem) <> T_STATUS_VISITED Then
+          status_(vItem) = T_STATUS_VISITED
+          Call iOrder.Add(vItem)
+        End If
+      End If
+    Loop
+NEXT_NODE:
+  Next vNode
+  
+  Set DefaultOrder = iOrder
+End Function
+
+Private Function InduceWidthOrder() As Collection
+  Dim iOrder As New Collection
+  
+  Call InitRanks
+  
+  Dim iQueue As Collection: Set iQueue = New Collection
+  Dim iKnown As New Scripting.Dictionary
+  Dim vNode As Variant
+  For Each vNode In CompleteInducedOrder
+    If ranks_(vNode) = 1 Then
+      Call iQueue.Add(vNode)
+      Call iKnown.Add(vNode, 0)
+    End If
+  Next vNode
+    
+  Do While iQueue.Count > 0
+    vNode = iQueue.Item(1)
+    Call iQueue.Remove(1)
+    Call iOrder.Add(vNode)
+    
+    If graph_.nodes_(vNode).outputs_.Count > 0 Then
+      Dim vChildren() As Variant: vChildren = ToArray(graph_.nodes_(vNode).outputs_)
+      Call SortChildren(vChildren)
+      Dim vChild As Variant
+      For Each vChild In vChildren
+        If Not iKnown.Exists(vChild) Then
+          If ranks_(vChild) = ranks_(vNode) + 1 Then
+            Call iQueue.Add(vChild)
+            Call iKnown.Add(vChild, 0)
+          End If
+        End If
+      Next vChild
+    End If
+  Loop
+
+  Set InduceWidthOrder = iOrder
+End Function
+
+Private Function InduceDepthOrder() As Collection
+  Dim iOrder As New Collection
+  
+  Call InitRanks
+
+  Dim iStack As Collection: Set iStack = New Collection
+  Dim iKnown As New Scripting.Dictionary
+  Dim vNode As Variant
+  For Each vNode In RevertCollection(CompleteInducedOrder)
+    If ranks_(vNode) = 1 Then
+      Call iStack.Add(vNode)
+    End If
+  Next vNode
+  
+  Dim vChildren() As Variant
+  Dim vChild As Variant
+  Dim nChild&
+  Do While iStack.Count > 0
+    vNode = iStack.Item(iStack.Count)
+    Call iStack.Remove(iStack.Count)
+    If iKnown.Exists(vNode) Then _
+      GoTo NEXT_ITEM
+      
+    Call iOrder.Add(vNode)
+    Call iKnown.Add(vNode, 0)
+
+    If graph_.nodes_(vNode).outputs_.Count > 0 Then
+      vChildren = ToArray(graph_.nodes_(vNode).outputs_)
+      Call SortChildren(vChildren)
+      For nChild = UBound(vChildren) To LBound(vChildren) Step -1
+        vChild = vChildren(nChild)
+        If Not iKnown.Exists(vChild) Then _
+          Call iStack.Add(vChild)
+      Next nChild
+    End If
+NEXT_ITEM:
+  Loop
+
+  Set InduceDepthOrder = iOrder
+End Function
+
+Private Function InitStatus()
+  Set status_ = New Scripting.Dictionary
+  Dim vNode As Variant
+  For Each vNode In nodes_
+    status_(vNode) = T_STATUS_UNVISITED
+  Next vNode
+End Function
+
+Private Function InitRanks()
+  Call InitStatus
+
+  Set ranks_ = New Scripting.Dictionary
+  Dim vNode As Variant
+  For Each vNode In CompleteInducedOrder
+    ranks_(vNode) = RANK_UNDEF
+  Next vNode
+  
+  For Each vNode In nodes_
+    Call PropagateRank(vNode, 1)
+  Next vNode
+End Function
+
+Private Function PropagateRank(vNode As Variant, nRank&)
+  If ranks_(vNode) >= nRank Then _
+    Exit Function
+  ranks_(vNode) = nRank
+  
+  If graph_.nodes_(vNode).outputs_.Count = 0 Then _
+    Exit Function
+  
+  status_(vNode) = T_STATUS_VISITING
+  
+  Dim vChildren() As Variant: vChildren = ToArray(graph_.nodes_(vNode).outputs_)
+  Call SortChildren(vChildren)
+  Dim vChild As Variant
+  For Each vChild In vChildren
+    If status_(vChild) <> T_STATUS_VISITING Then _
+      Call PropagateRank(vChild, nRank + 1)
+  Next vChild
+  
+  status_(vNode) = T_STATUS_VISITED
+End Function
+
+Private Function InitSourceOrder(iSourceOrder As Collection)
+  Set sourceOrder_ = New Scripting.Dictionary
+  Dim aVal As Variant
+  Dim nIndex&: nIndex = 1
+  For Each aVal In iSourceOrder
+    If graph_.HasNode(aVal) Then
+      sourceOrder_(aVal) = nIndex
+      nIndex = nIndex + 1
+    End If
+  Next aVal
+End Function
+
+Private Function CompleteInducedOrder() As Collection
+  Dim iOrder As New Collection
+  Dim vItem As Variant
+  For Each vItem In sourceOrder_
+    Call iOrder.Add(vItem)
+  Next vItem
+  
+  If iOrder.Count = graph_.Size Then
+    Set CompleteInducedOrder = iOrder
+    Exit Function
+  End If
+  
+  For Each vItem In nodes_
+    If Not sourceOrder_.Exists(vItem) Then _
+      Call iOrder.Add(vItem)
+  Next vItem
+  
+  Set CompleteInducedOrder = iOrder
+End Function
+
+Private Function SortChildren(ByRef target() As Variant)
+  If UBound(target) < 1 Then _
+    Exit Function
+  Dim i&, j&
+  Dim vItem As Variant
+  For i = LBound(target) + 1 To UBound(target) Step 1
+    vItem = target(i)
+    Dim nIndex&: nIndex = GetNodeIndex(vItem)
+    j = i - 1
+    Do While j >= 0
+      If GetNodeIndex(target(j)) <= nIndex Then _
+        Exit Do
+      target(j + 1) = target(j)
+      j = j - 1
+    Loop
+    target(j + 1) = vItem
+  Next i
+End Function
+
+Private Function GroupNodesDefault(iNodes As Collection) As Collection
+  Dim iResult As New Collection
+  Dim nComponent&
+  For nComponent = 0 To componentCount_ - 1 Step 1
+    Dim vNode As Variant
+    For Each vNode In iNodes
+      If Not sourceOrder_ Is Nothing Then _
+        If Not sourceOrder_.Exists(vNode) Then _
+          GoTo NEXT_NODE
+      If nodeComponents_(vNode) = nComponent Then _
+        Call iResult.Add(vNode)
+NEXT_NODE:
+    Next vNode
+  Next nComponent
+  Set GroupNodesDefault = iResult
+End Function
+
+Private Function GetNodeIndex(vNode As Variant) As Long
+  If sourceOrder_.Exists(vNode) Then
+    GetNodeIndex = sourceOrder_(vNode)
+  Else
+    GetNodeIndex = MAX_NODE_INDEX
+  End If
+End Function
+
+Private Function SortComponents(iNodesOrder As Collection) As Collection
+  Dim iOrder As New Collection
+  Dim nComponent&
+  Dim vNode As Variant
+  For Each vNode In iNodesOrder
+    nComponent = nodeComponents_(vNode)
+    Call SafeAddToCollection(nComponent, VBA.CStr(nComponent), iOrder)
+  Next vNode
+  Set SortComponents = iOrder
+End Function
+
+Private Function GroupNodesInduced(iNodes As Collection, iComponents As Collection) As Collection
+  Dim iResult As New Collection
+  Dim nComponent As Variant
+  For Each nComponent In iComponents
+    Dim vNode As Variant
+    For Each vNode In iNodes
+      If Not sourceOrder_.Exists(vNode) Then _
+        GoTo NEXT_NODE
+      If nodeComponents_(vNode) = nComponent Then _
+        Call iResult.Add(vNode)
+NEXT_NODE:
+    Next vNode
+  Next nComponent
+  Set GroupNodesInduced = iResult
+End Function
+

utility/API_JSON.cls

@@ -0,0 +1,618 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_JSON"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ======== JSON converter ========
+' Shared module version: 20220813
+' Tested in: TestCommons
+' Depends on:
+' Required reference: Scripting
+' This code is based on rethinking VBA-JSON,  https://github.com/VBA-tools/VBA-JSON
+Option Explicit
+
+Private Const ERR_PARSE_FAIL = vbObject + 2049
+
+' JSON states esaping '/' as optional.
+' Use this flag to escape them as '\/'
+Public escapeSlash_ As Boolean
+
+' JSON doesnt require escaping of non-AscII chars.
+' Use this flag to enable \u codes escape mechanics
+Public escapeUnicode_ As Boolean
+
+Private multiline_ As Boolean
+Private wsCharacter_ As String
+Private wsCount_ As Long
+
+Private json_ As String
+Private inputLen_ As Long
+Private position_ As Long
+
+Private Sub Class_Initialize()
+  escapeSlash_ = False
+  escapeUnicode_ = False
+  Call DisableMultiline
+End Sub
+
+' {Integer|String} vWhitespace "Pretty" print json with given number of spaces per indentation (Integer) or given string
+Public Function SetupMultiline(ByVal vWhitespace As Variant)
+  multiline_ = True
+  If VBA.VarType(vWhitespace) = VBA.vbString Then
+    wsCharacter_ = vWhitespace
+    wsCount_ = -1
+  Else
+    wsCharacter_ = vbNullString
+    wsCount_ = vWhitespace
+  End If
+End Function
+
+Public Function DisableMultiline()
+  multiline_ = False
+  wsCharacter_ = vbNullString
+  wsCount_ = -1
+End Function
+
+' Convert object (Dictionary/Collection/Array) to JSON
+Public Function CreateJSON(ByRef vValue As Variant) As String
+  CreateJSON = Generator_Process(vValue)
+End Function
+
+' Convert JSON string to object (Dictionary/Collection)
+Public Function Parse(sJson$) As Object
+  json_ = VBA.Replace(VBA.Replace(VBA.Replace(sJson, VBA.vbCr, ""), VBA.vbLf, ""), VBA.vbTab, "")
+  position_ = 1
+  inputLen_ = VBA.Len(json_)
+
+  Call Parser_SkipWS
+  
+  Select Case Parser_ViewAny()
+  Case "{": Set Parse = Parser_Object()
+  Case "[": Set Parse = Parser_Array()
+  Case Else: Call Parser_RaiseError("Expected '{' or '['")
+  End Select
+  
+  If position_ <= inputLen_ Then _
+    Call Parser_RaiseError("Some part of input is out of main object scope")
+  
+  json_ = vbNullString
+End Function
+
+Public Function SaveToFile(sFile$, iData As Object) As Boolean
+  Const DO_OVERWRITE& = 2
+
+  SaveToFile = False
+  On Error GoTo EXIT_ERROR
+  
+  Dim adoStream As Object: Set adoStream = CreateObject("ADODB.Stream")
+  adoStream.Charset = "utf-8"
+  Call adoStream.Open
+  Call adoStream.WriteText(CreateJSON(iData))
+  Call adoStream.SaveToFile(sFile, DO_OVERWRITE)
+  
+  SaveToFile = True
+  
+EXIT_ERROR:
+  On Error GoTo 0
+  Call adoStream.Close
+End Function
+
+Public Function LoadFromFile(sFile$) As Object
+  Dim sJson$: sJson = ReadFile(sFile)
+  If sJson = vbNullString Then _
+    Exit Function
+  Set LoadFromFile = Parse(sJson)
+End Function
+
+' =============================================
+Private Function ReadFile(sFile$) As String
+  Dim adoStream As Object: Set adoStream = CreateObject("ADODB.Stream")
+  adoStream.Charset = "utf-8"
+  Call adoStream.Open
+  
+  On Error GoTo ERROR_FILE
+  Call adoStream.LoadFromFile(sFile)
+  On Error GoTo 0
+  
+  ReadFile = adoStream.ReadText
+  
+ERROR_FILE:
+  Call adoStream.Close
+  On Error GoTo 0
+End Function
+
+Private Function Generator_Process(ByRef vValue As Variant, Optional nIdent& = 0) As String
+  Select Case VBA.VarType(vValue)
+  Case VBA.vbNull: Generator_Process = "null"
+  Case VBA.vbBoolean: Generator_Process = IIf(vValue, "true", "false")
+  Case VBA.vbDate: Generator_Process = """" & CDbl(vValue) & """"
+  Case VBA.vbString
+    If IsLargeNumber(vValue) Then
+      Generator_Process = vValue ' Large number encoded as string
+    Else
+      Generator_Process = """" & EncodeStr(vValue) & """"
+    End If
+    
+  Case VBA.vbArray To VBA.vbArray + VBA.vbByte: Generator_Process = Generator_Array(vValue, nIdent)
+  
+  Case VBA.vbObject
+    If VBA.TypeName(vValue) = "Dictionary" Then
+      Generator_Process = Generator_Dictionary(vValue, nIdent)
+    ElseIf VBA.TypeName(vValue) = "Collection" Then
+      Generator_Process = Generator_Collection(vValue, nIdent)
+    Else ' TODO: call custom object function to generate JSON!
+      Call Err.Raise(1000, Description:="Unknown object type. Please use Dictionary or Collection")
+    End If
+
+  Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal
+    Generator_Process = VBA.Replace(vValue, ",", ".") ' Number (use decimals for numbers)
+  Case Else ' vbEmpty, vbError, vbDataObject, vbByte, vbUserDefinedType
+    On Error Resume Next
+    Generator_Process = vValue
+    On Error GoTo 0
+  End Select
+End Function
+
+Private Function Generator_Array(ByRef vValue As Variant, nIdent&) As String
+  Dim sBuffer$
+  Dim nBufferPosition&
+  Dim nBufferLen&
+  Call BufferAppend(sBuffer, "[", nBufferPosition, nBufferLen)
+  
+  Dim nSize1&: nSize1 = ArraySize(vValue, 1)
+  If nSize1 <= 0 Then _
+    GoTo PRINT_TO_STR
+  Dim nIndex1Start&: nIndex1Start = LBound(vValue, 1)
+  
+  Dim nSize2&: nSize2 = ArraySize(vValue, 2)
+  Dim nIndex2Start&
+  If nSize2 > 0 Then _
+    nIndex2Start = LBound(vValue, 2)
+
+  Dim sIndentLevel1$: sIndentLevel1 = GetWS(nIdent + 1)
+  Dim sIndentLevel2$: sIndentLevel2 = GetWS(nIdent + 2)
+
+  Dim bIsFirst: bIsFirst = True
+  Dim json_Converted$
+  Dim nIndex1&
+  For nIndex1 = nIndex1Start To nIndex1Start + nSize1 - 1 Step 1
+    If Not bIsFirst Then
+      Call BufferAppend(sBuffer, ",", nBufferPosition, nBufferLen)
+    Else
+      bIsFirst = False
+    End If
+
+    If nSize2 <= 0 Then  ' 1D Array
+      json_Converted = Generator_Nullable(vValue(nIndex1), nIdent + 1)
+      If multiline_ Then _
+        json_Converted = vbNewLine & sIndentLevel1 & json_Converted
+      Call BufferAppend(sBuffer, json_Converted, nBufferPosition, nBufferLen)
+    Else ' 2D Array
+      If multiline_ Then _
+        Call BufferAppend(sBuffer, vbNewLine, nBufferPosition, nBufferLen)
+      Call BufferAppend(sBuffer, sIndentLevel1 & "[", nBufferPosition, nBufferLen)
+      
+      Dim nIndex2&
+      Dim bIsFirst2 As Boolean: bIsFirst2 = True
+      For nIndex2 = nIndex2Start To nIndex2Start + nSize2 - 1 Step 1
+        If Not bIsFirst2 Then
+          Call BufferAppend(sBuffer, ",", nBufferPosition, nBufferLen)
+        Else
+          bIsFirst2 = False
+        End If
+        json_Converted = Generator_Nullable(vValue(nIndex1, nIndex2), nIdent + 2)
+        If multiline_ Then _
+          json_Converted = vbNewLine & sIndentLevel2 & json_Converted
+        Call BufferAppend(sBuffer, json_Converted, nBufferPosition, nBufferLen)
+      Next nIndex2
+
+      If multiline_ Then _
+        Call BufferAppend(sBuffer, vbNewLine, nBufferPosition, nBufferLen)
+      Call BufferAppend(sBuffer, sIndentLevel1 & "]", nBufferPosition, nBufferLen)
+    End If
+  Next nIndex1
+
+PRINT_TO_STR:
+  On Error GoTo 0
+  
+  If multiline_ Then
+    Call BufferAppend(sBuffer, vbNewLine & GetWS(nIdent) & "]", nBufferPosition, nBufferLen)
+  Else
+    Call BufferAppend(sBuffer, "]", nBufferPosition, nBufferLen)
+  End If
+  Generator_Array = BufferToString(sBuffer, nBufferPosition)
+End Function
+
+Private Function Generator_Collection(ByRef vValue As Variant, nIdent&) As String
+  Dim sBuffer$
+  Dim nBufferPosition&
+  Dim nBufferLen&
+  Call BufferAppend(sBuffer, "[", nBufferPosition, nBufferLen)
+  
+  Dim bIsFirst As Boolean: bIsFirst = True
+  Dim anElement As Variant
+  For Each anElement In vValue
+    If Not bIsFirst Then
+      Call BufferAppend(sBuffer, ",", nBufferPosition, nBufferLen)
+    Else
+      bIsFirst = False
+    End If
+
+    Dim json_Converted$: json_Converted = Generator_Nullable(anElement, nIdent + 1)
+    If multiline_ Then _
+      json_Converted = vbNewLine & GetWS(nIdent + 1) & json_Converted
+    Call BufferAppend(sBuffer, json_Converted, nBufferPosition, nBufferLen)
+  Next anElement
+
+  If multiline_ Then
+    Call BufferAppend(sBuffer, vbNewLine & GetWS(nIdent) & "]", nBufferPosition, nBufferLen)
+  Else
+    Call BufferAppend(sBuffer, "]", nBufferPosition, nBufferLen)
+  End If
+  Generator_Collection = BufferToString(sBuffer, nBufferPosition)
+End Function
+
+Private Function Generator_Dictionary(ByRef vValue As Variant, nIdent&) As String
+  Dim sBuffer$
+  Dim nBufferPosition&
+  Dim nBufferLen&
+  Call BufferAppend(sBuffer, "{", nBufferPosition, nBufferLen)
+  
+  Dim bIsFirst As Boolean: bIsFirst = True
+  Dim aKey As Variant
+  For Each aKey In vValue.Keys
+    Dim json_Converted$: json_Converted = Generator_Process(vValue(aKey), nIdent + 1)
+    If json_Converted = vbNullString Then _
+      If IsUndefined(vValue(aKey)) Then _
+        GoTo NEXT_KEY ' For Objects, undefined (Empty/Nothing) is not added to object
+
+    If Not bIsFirst Then
+      Call BufferAppend(sBuffer, ",", nBufferPosition, nBufferLen)
+    Else
+      bIsFirst = False
+    End If
+    
+    If multiline_ Then
+      json_Converted = vbNewLine & GetWS(nIdent + 1) & """" & aKey & """: " & json_Converted
+    Else
+      json_Converted = """" & aKey & """:" & json_Converted
+    End If
+
+    Call BufferAppend(sBuffer, json_Converted, nBufferPosition, nBufferLen)
+NEXT_KEY:
+  Next aKey
+
+  If multiline_ Then
+    Call BufferAppend(sBuffer, vbNewLine & GetWS(nIdent) & "}", nBufferPosition, nBufferLen)
+  Else
+    Call BufferAppend(sBuffer, "}", nBufferPosition, nBufferLen)
+  End If
+  Generator_Dictionary = BufferToString(sBuffer, nBufferPosition)
+End Function
+
+Private Function Generator_Nullable(ByVal vValue As Variant, nIdent&)
+  Generator_Nullable = Generator_Process(vValue, nIdent)
+  If Generator_Nullable = vbNullString Then _
+    If IsUndefined(vValue) Then _
+      Generator_Nullable = "null"
+End Function
+
+Private Function Parser_Object() As Scripting.Dictionary
+  If Parser_ConsumeChar() <> "{" Then _
+    Call Parser_RaiseError("Expected '{'")
+    
+  Set Parser_Object = New Scripting.Dictionary
+  Do
+    Call Parser_SkipWS
+    Dim sNextChar$: sNextChar = Parser_ViewChar()
+    If sNextChar = "}" Then
+      Call Parser_Increment
+      Exit Function
+    ElseIf sNextChar = "," Then
+      Call Parser_Increment
+      Call Parser_SkipWS
+    End If
+
+    Dim sKey$: sKey = Parser_Key()
+    If Parser_ConsumeChar(1) <> ":" Then _
+      Call Parser_RaiseError("Expected ':'")
+    sNextChar = Parser_ViewChar()
+    If sNextChar = "[" Or sNextChar = "{" Then
+      Set Parser_Object.Item(sKey) = Parser_Value()
+    Else
+      Parser_Object.Item(sKey) = Parser_Value()
+    End If
+  Loop
+End Function
+
+Private Function Parser_Array() As Collection
+  If Parser_ConsumeChar() <> "[" Then _
+    Call Parser_RaiseError("Expected '['")
+  
+  Set Parser_Array = New Collection
+  Do
+    Call Parser_SkipWS
+    Dim sChar$: sChar = Parser_ViewChar(1)
+    If sChar = "]" Then
+      Call Parser_Increment
+      Exit Function
+    ElseIf sChar = "," Then
+      Call Parser_Increment
+    End If
+    Call Parser_Array.Add(Parser_Value())
+  Loop
+End Function
+
+Private Function Parser_Value() As Variant
+  Call Parser_SkipWS
+  Dim sValue$: sValue = Parser_ViewAny(1)
+  Select Case sValue
+  Case "{": Set Parser_Value = Parser_Object()
+  Case "[": Set Parser_Value = Parser_Array()
+  Case """", "'": Parser_Value = Parser_String()
+  Case Else
+    If VBA.InStr("+-0123456789", sValue) Then
+      Parser_Value = Parser_Numbers()
+      Exit Function
+    End If
+    
+    If inputLen_ - position_ + 1 > 4 Then
+      sValue = Parser_ViewAny(4)
+      If sValue = "true" Then
+        Parser_Value = True
+        Call Parser_Increment(4)
+        Exit Function
+      ElseIf sValue = "null" Then
+        Parser_Value = Null
+        Call Parser_Increment(4)
+        Exit Function
+      End If
+    End If
+    
+    If inputLen_ - position_ + 1 > 5 Then
+      sValue = Parser_ViewAny(5)
+      If sValue = "false" Then
+        Parser_Value = False
+        Call Parser_Increment(5)
+        Exit Function
+      End If
+    End If
+      
+    Call Parser_RaiseError("Expected 'STRING', 'NUMBER', null, true, false, '{', or '['")
+  End Select
+End Function
+
+Private Function Parser_String() As String
+  Dim sBuffer$
+  Dim nBufferPosition&
+  Dim nBufferLen&
+  
+  Dim sChar$
+  Dim json_Quote$: json_Quote = Parser_ConsumeChar()
+  Do While position_ <= inputLen_
+    sChar = Parser_ConsumeAny(1)
+    If sChar = json_Quote Then
+      Parser_String = BufferToString(sBuffer, nBufferPosition)
+      Exit Function
+    ElseIf sChar = "\" Then
+    ' Escaped string, \\, or \/
+      sChar = Parser_ConsumeAny(1)
+      Select Case sChar
+      Case """", "\", "/", "'": Call BufferAppend(sBuffer, sChar, nBufferPosition, nBufferLen)
+      Case "b": Call BufferAppend(sBuffer, vbBack, nBufferPosition, nBufferLen)
+      Case "f": Call BufferAppend(sBuffer, vbFormFeed, nBufferPosition, nBufferLen)
+      Case "n": Call BufferAppend(sBuffer, vbCrLf, nBufferPosition, nBufferLen)
+      Case "r": Call BufferAppend(sBuffer, vbCr, nBufferPosition, nBufferLen)
+      Case "t": Call BufferAppend(sBuffer, vbTab, nBufferPosition, nBufferLen)
+      Case "u"
+        Dim sUTF8Char$: sUTF8Char = Parser_ViewAny(4)
+        Call BufferAppend(sBuffer, VBA.ChrW(VBA.val("&h" + sUTF8Char)), nBufferPosition, nBufferLen)
+        Call Parser_Increment(4)
+      Case Else: Call Parser_Increment(-1)
+      End Select
+    Else
+      Call BufferAppend(sBuffer, sChar, nBufferPosition, nBufferLen)
+    End If
+  Loop
+End Function
+
+Private Function Parser_Numbers() As Variant
+  Call Parser_SkipWS
+  Dim sChar$
+  Dim sValue$: sValue = vbNullString
+  Do While position_ <= inputLen_
+    sChar = Parser_ViewAny(1)
+    If VBA.InStr("+-0123456789.eE", sChar) Then
+      sValue = sValue & sChar
+      Call Parser_Increment(1)
+    Else
+      ' Fix: Parse -> String, Convert -> String longer than 15/16 characters containing only numbers and decimal points -> Number
+      Dim bIsLarge As Boolean: bIsLarge = IIf(VBA.InStr(sValue, "."), VBA.Len(sValue) >= 17, VBA.Len(sValue) >= 16)
+      If bIsLarge Then
+        Parser_Numbers = sValue
+      Else
+        Parser_Numbers = VBA.val(sValue)
+      End If
+      Exit Function
+    End If
+  Loop
+End Function
+
+Private Function Parser_Key() As String
+  Dim sChar$: sChar = Parser_ViewAny(1)
+  If sChar = """" Or sChar = "'" Then
+    Parser_Key = Parser_String
+  Else
+    Call Parser_RaiseError("Expected '""' or '''")
+  End If
+End Function
+
+' View nChars from input
+Private Function Parser_ViewAny(Optional nChars& = 1) As String
+  If position_ + nChars - 1 > inputLen_ Then _
+    Call Parser_RaiseError("Unexpected end of input")
+  Parser_ViewAny = VBA.Mid$(json_, position_, nChars)
+End Function
+
+' View nChar symboms (skipping spaces)
+Private Function Parser_ViewChar(Optional nChars& = 1) As String
+  Dim nPosition&: nPosition = position_
+  Do While nPosition > 0 And nPosition <= inputLen_ And VBA.Mid$(json_, nPosition, 1) = " "
+    nPosition = nPosition + 1
+  Loop
+  If nPosition + nChars - 1 > inputLen_ Then _
+    Call Parser_RaiseError("Unexpected end of input")
+  Parser_ViewChar = VBA.Mid$(json_, nPosition, nChars)
+End Function
+
+' Consumne nChars symbols from input
+Private Function Parser_ConsumeAny(Optional nChars& = 1) As String
+  If position_ + nChars - 1 > inputLen_ Then _
+    Call Parser_RaiseError("Unexpected end of input")
+  Parser_ConsumeAny = VBA.Mid$(json_, position_, nChars)
+  Call Parser_Increment(nChars)
+End Function
+
+' Consume nChars from input (skipping spaces)
+Private Function Parser_ConsumeChar(Optional nChars& = 1) As String
+  Call Parser_SkipWS
+  If position_ + nChars - 1 > inputLen_ Then _
+    Call Parser_RaiseError("Unexpected end of input")
+  Parser_ConsumeChar = VBA.Mid$(json_, position_, nChars)
+  Call Parser_Increment(nChars)
+End Function
+
+Private Function Parser_Increment(Optional nIncrement& = 1)
+  position_ = position_ + nIncrement
+End Function
+
+Private Function Parser_SkipWS()
+  Do While position_ <= inputLen_ And VBA.Mid$(json_, position_, 1) = " "
+    Call Parser_Increment
+  Loop
+End Function
+
+Private Function Parser_RaiseError(sMessage$)
+  Dim nStart&: nStart = position_ - 10
+  If nStart <= 0 Then _
+    nStart = 1
+    
+  Dim nEnd&: nEnd = position_ + 10
+  If nEnd > inputLen_ Then _
+    nEnd = inputLen_
+  
+  Dim sErrorMsg$: sErrorMsg = "Error parsing JSON:" & VBA.vbNewLine & _
+              VBA.Mid$(json_, nStart, nEnd - nStart + 1) & VBA.vbNewLine & _
+              VBA.Space$(position_ - nStart) & "^" & VBA.vbNewLine & _
+              sMessage
+  Call Err.Raise(ERR_PARSE_FAIL, "JSONConverter", sErrorMsg)
+End Function
+
+Private Function ArraySize(target As Variant, Optional nDimension% = 1) As Long
+  On Error GoTo INVALID_SIZE
+  
+  ArraySize = UBound(target, nDimension) - LBound(target, nDimension) + 1
+  Exit Function
+
+INVALID_SIZE:
+  ArraySize = -1
+End Function
+
+Private Function IsUndefined(ByVal vValue As Variant) As Boolean
+  ' Empty / Nothing -> undefined
+  Select Case VBA.VarType(vValue)
+  Case VBA.vbEmpty
+    IsUndefined = True
+  Case VBA.vbObject
+    Select Case VBA.TypeName(vValue)
+    Case "Empty", "Nothing"
+      IsUndefined = True
+    End Select
+  End Select
+End Function
+
+Private Function EncodeStr(ByVal sText As Variant) As String
+  Dim sBuffer$: sBuffer = vbNullString
+  Dim nBufferPosition&
+  Dim nBufferLen&
+  
+  Dim sChar$
+  Dim nCharCode&
+  Dim nPosition&
+  For nPosition = 1 To VBA.Len(sText)
+    sChar = VBA.Mid$(sText, nPosition, 1)
+    nCharCode = VBA.AscW(sChar)
+
+    ' Convert negative complement into char code, see: https://support.microsoft.com/en-us/kb/272138
+    If nCharCode < 0 Then _
+      nCharCode = nCharCode + 65536
+
+    Select Case nCharCode
+    Case 34: sChar = "\"""
+    Case 92: sChar = "\\"
+    Case 47: If escapeSlash_ Then sChar = "\/"
+    Case 8: sChar = "\b"
+    Case 12: sChar = "\f"
+    Case 10: sChar = "\n"
+    Case 13: sChar = "\r"
+    Case 9: sChar = "\t"
+    Case 0 To 31, 127 To 65535: If escapeUnicode_ Then sChar = "\u" & VBA.Right$("0000" & VBA.Hex$(nCharCode), 4)
+    End Select
+
+    Call BufferAppend(sBuffer, sChar, nBufferPosition, nBufferLen)
+  Next nPosition
+
+  EncodeStr = BufferToString(sBuffer, nBufferPosition)
+End Function
+
+Private Function IsLargeNumber(sJson As Variant) As Boolean
+  Dim nLength&: nLength = VBA.Len(sJson)
+  If nLength < 16 Or nLength >= 100 Then _
+    Exit Function
+    
+  IsLargeNumber = True
+  Dim nIndex&
+  For nIndex = 1 To nLength Step 1
+    Select Case VBA.Asc(VBA.Mid$(sJson, nIndex, 1))
+    Case 46, 48 To 57, 69, 101 ' Look for .|0-9|E|e
+      ' Continue through characters
+    Case Else
+      IsLargeNumber = False
+      Exit Function
+    End Select
+  Next nIndex
+End Function
+
+Private Function GetWS(nIdent&) As String
+  If Not multiline_ Then _
+    Exit Function
+  If wsCount_ <> -1 Then
+    GetWS = VBA.Space$(nIdent * wsCount_)
+  Else
+    GetWS = VBA.String$(nIdent, wsCharacter_)
+  End If
+End Function
+
+Private Function BufferAppend(ByRef sBuffer$, ByRef vAppendage As Variant, ByRef nBufferPosition&, ByRef nBufferLen&)
+  ' Allocate a large empty string and then copy string at append position instead of allocating for each append
+  Dim nAppendLen&: nAppendLen = VBA.Len(vAppendage)
+
+  If nAppendLen + nBufferPosition > nBufferLen Then
+    Dim nAddedLength&: nAddedLength = IIf(nAppendLen > nBufferLen, nAppendLen, nBufferLen)
+    sBuffer = sBuffer & VBA.Space$(nAddedLength)
+    nBufferLen = nBufferLen + nAddedLength
+  End If
+  
+  ' Access and modify buffer using Mid$
+  Mid$(sBuffer, nBufferPosition + 1, nAppendLen) = CStr(vAppendage)
+  nBufferPosition = nBufferPosition + nAppendLen
+End Function
+
+Private Function BufferToString(ByRef sBuffer$, nBufferPosition&) As String
+  If nBufferPosition > 0 Then _
+    BufferToString = VBA.Left$(sBuffer, nBufferPosition)
+End Function

utility/API_LinkedComponents.cls

@@ -0,0 +1,61 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_LinkedComponents"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ======= Graph linked components =====
+' Shared module version: 20210411
+' Tested in: TestCommons
+' Depends on: CDS_Graph
+' Required reference: Scripting
+Option Explicit
+
+Private graph_ As CDS_Graph
+Private maxId_ As Long
+Private components_ As Scripting.Dictionary
+
+Public Property Get CountComponents() As Long
+  CountComponents = maxId_
+End Property
+
+Public Function GetComponents(iGraph As CDS_Graph) As Scripting.Dictionary
+  maxId_ = 0
+  Set components_ = New Scripting.Dictionary
+  Set graph_ = iGraph
+  
+  Dim vNode As Variant
+  For Each vNode In graph_.Nodes
+    If Not components_.Exists(vNode) Then
+      Call VisitNode(vNode)
+      maxId_ = maxId_ + 1
+    End If
+  Next vNode
+  Set GetComponents = components_
+End Function
+
+' =========
+Private Function VisitNode(vNode As Variant)
+  If components_.Exists(vNode) Then _
+    Exit Function
+  Call components_.Add(vNode, maxId_)
+  Call VisitParents(vNode)
+  Call VisitChildren(vNode)
+End Function
+
+Private Function VisitParents(vNode As Variant)
+  Dim vParent As Variant
+  For Each vParent In graph_.nodes_(vNode).inputs_
+    Call VisitNode(vParent)
+  Next vParent
+End Function
+
+Private Function VisitChildren(vNode As Variant)
+  Dim vParent As Variant
+  For Each vParent In graph_.nodes_(vNode).outputs_
+    Call VisitNode(vParent)
+  Next vParent
+End Function

utility/API_StrongComponents.cls

@@ -0,0 +1,101 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_StrongComponents"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ===== Graph strongly linked components ====
+' Shared module version: 20220408
+' Tested in: TestCommons
+' Depends on: CDS_Graph
+' Required reference:
+Option Explicit
+
+Private graph_ As CDS_Graph
+Private components_ As Collection
+Private current_ As Scripting.Dictionary
+
+Private visited_ As Scripting.Dictionary
+Private reversedOrder_ As Scripting.Dictionary
+
+Public Function GetComponents(iGraph As CDS_Graph) As Collection
+  Set graph_ = iGraph
+  Set components_ = New Collection
+ 
+  Call CalculateOrder
+  Call ScanComponents
+  
+  Set GetComponents = components_
+End Function
+
+' =============
+Private Function CalculateOrder()
+  Set visited_ = New Scripting.Dictionary
+  Set reversedOrder_ = New Scripting.Dictionary
+  
+  Dim vNode As Variant
+  For Each vNode In graph_.Nodes
+    If Not visited_.Exists(vNode) Then
+      Call VisitInversed(vNode)
+    End If
+  Next vNode
+End Function
+
+Private Function ScanComponents()
+  Set visited_ = New Scripting.Dictionary
+  Dim nItem&
+  Dim vItems As Variant: vItems = reversedOrder_.Keys()
+  For nItem = UBound(vItems, 1) To LBound(vItems, 1) Step -1
+    Dim nodeID As Variant: nodeID = vItems(nItem)
+    If visited_.Exists(nodeID) Then _
+      GoTo NEXT_NODE
+      
+    Set current_ = New Scripting.Dictionary
+    Call VisitNode(nodeID)
+    If current_.Count = 1 Then
+      If Not graph_.HasEdge(nodeID, nodeID) Then _
+        GoTo NEXT_NODE
+    End If
+    Call components_.Add(current_)
+NEXT_NODE:
+  Next nItem
+End Function
+
+Private Function VisitInversed(nodeID As Variant)
+  Call visited_.Add(nodeID, 0)
+  Call VisitChildrenInversed(nodeID)
+  Call reversedOrder_.Add(nodeID, 0)
+End Function
+
+Private Function VisitChildrenInversed(nodeID As Variant)
+  If graph_.nodes_(nodeID).inputs_.Count = 0 Then _
+    Exit Function
+  
+  Dim parentID As Variant
+  For Each parentID In graph_.nodes_(nodeID).inputs_
+    If Not visited_.Exists(parentID) Then _
+      Call VisitInversed(parentID)
+  Next parentID
+End Function
+
+Private Function VisitNode(nodeID As Variant)
+  Call visited_.Add(nodeID, 0)
+  Call current_.Add(nodeID, 0)
+  Call VisitChildren(nodeID)
+End Function
+
+Private Function VisitChildren(nodeID As Variant)
+  If graph_.nodes_(nodeID).outputs_.Count = 0 Then _
+    Exit Function
+    
+  Dim childID As Variant
+  For Each childID In graph_.nodes_(nodeID).outputs_
+    If Not visited_.Exists(childID) Then _
+      Call VisitNode(childID)
+  Next childID
+End Function
+
+

utility/API_Timer.cls

@@ -0,0 +1,63 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_Timer"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+'=========== Precise timer wrapper =============
+' Shared module version: 20210528
+' Tested in:
+' Depends on:
+' Required reference:
+Option Explicit
+
+Private Type BigInt
+  lowPart As Long
+  highPart As Long
+End Type
+
+Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As BigInt) As Long
+Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As BigInt) As Long
+
+Private Const TWO_32 = 4294967296#
+
+Private start_ As BigInt
+Private finish_ As BigInt
+Private frequency_ As Double
+
+Public Function Start()
+  Call QueryPerformanceCounter(start_)
+End Function
+
+' Time elapsed in milliseconds
+Public Property Get TimeElapsed() As Double
+  Dim crStart As Double
+  Dim crStop As Double
+  QueryPerformanceCounter finish_
+  crStart = BigInt2Double(start_)
+  crStop = BigInt2Double(finish_)
+  TimeElapsed = 1000# * (crStop - crStart) / frequency_
+End Property
+
+Public Property Get TimeStr() As String
+  TimeStr = VBA.Format(TimeElapsed, "# ##0.###") & " ms"
+End Property
+
+' ====
+Private Function BigInt2Double(theInt As BigInt) As Double
+  Dim lowPart As Double
+  lowPart = theInt.lowPart
+  If lowPart < 0 Then
+    lowPart = lowPart + TWO_32
+  End If
+  BigInt2Double = theInt.highPart * TWO_32 + lowPart
+End Function
+
+Private Sub Class_Initialize()
+  Dim freq As BigInt
+  Call QueryPerformanceFrequency(freq)
+  frequency_ = BigInt2Double(freq)
+End Sub

utility/CDS_CompoundIntervals.cls

@@ -0,0 +1,67 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "CDS_CompoundIntervals"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' === Óïîðÿäî÷åííûé íàáîð íåïåðåñåêàþùèõñÿ èíòåðâàëîâ  ====
+' Shared module version: 20210511
+' Tested in: TestCommons
+' Depends on: CDS_Interval
+' Required reference:
+Option Explicit
+
+Public items_ As Collection ' of CDS_Interval
+
+Private Sub Class_Initialize()
+  Call Clear
+End Sub
+
+Public Property Get Count() As Long
+  Count = items_.Count
+End Property
+
+Public Property Get IsEmpty() As Boolean
+  IsEmpty = Count = 0
+End Property
+
+Public Function AddItem(nStart&, nFinish&)
+  If nFinish < nStart Then _
+    Exit Function
+  Call AddInternal(CreateInterval(nStart, nFinish))
+End Function
+
+Public Function Clear()
+  Set items_ = New Collection
+End Function
+
+' =======
+Private Function AddInternal(ByRef newItem As CDS_Interval)
+  Dim nItem&: nItem = 1
+  Dim nextItem As CDS_Interval
+  For Each nextItem In items_
+    If nextItem.start_ > newItem.finish_ Then
+      Call items_.Add(newItem, Before:=nItem)
+      Exit Function
+    ElseIf nextItem.finish_ >= newItem.finish_ Then
+      If nextItem.start_ > newItem.start_ Then _
+        nextItem.start_ = newItem.start_
+      Exit Function
+    ElseIf nextItem.finish_ >= newItem.start_ Then
+      newItem.start_ = nextItem.start_
+      Call items_.Remove(nItem)
+      Call AddInternal(newItem)
+      Exit Function
+    End If
+    nItem = nItem + 1
+  Next nextItem
+  Call items_.Add(newItem)
+End Function
+
+Private Function CreateInterval(nStart&, nFinish&) As CDS_Interval
+  Dim iNewItem As New CDS_Interval: Call iNewItem.Init(nStart, nFinish)
+  Set CreateInterval = iNewItem
+End Function

utility/CDS_Edge.cls

@@ -0,0 +1,48 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "CDS_Edge"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ========== Class Module for Graph edge ========
+' Shared module version: 20210410
+' Tested in: TestCommons
+' Depends on: ex_VBA
+' Required reference:
+Option Explicit
+
+Public source_ As Variant
+Public dest_ As Variant
+
+Public Function Init(vSource As Variant, vDestination As Variant)
+  source_ = vSource
+  dest_ = vDestination
+End Function
+
+Public Function Clone() As CDS_Edge
+  Set Clone = New CDS_Edge
+  Call Clone.Init(source_, dest_)
+End Function
+
+Public Function Reversed() As CDS_Edge
+  Dim iEdge As New CDS_Edge
+  Call iEdge.Init(dest_, source_)
+  Set Reversed = iEdge
+End Function
+
+Public Property Get ID() As String
+  ID = VBA.CStr(source_) & "-" & VBA.CStr(dest_)
+End Property
+
+Public Function Compare(rhs As Variant) As Double
+  Compare = CompareDeep(source_, rhs.source_)
+  If Compare = 0 Then _
+    Compare = CompareDeep(dest_, rhs.dest_)
+End Function
+
+Public Function ToString(Optional nIndent& = 0) As String
+  ToString = "$Edge " & ID
+End Function

utility/CDS_Factorizator.cls

@@ -0,0 +1,76 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "CDS_Factorizator"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ========= Module for floating point value groupings ===============
+' Shared module version: 20210412
+' Tested in: TestVisio
+' Depends on:
+' Required reference: Scripting
+
+' Note: elements should be comparable
+Option Explicit
+
+Private gap_ As Double
+Private values_ As Scripting.Dictionary
+Private factors_ As Scripting.Dictionary
+
+Public Function Init(dDividerGap As Double)
+  gap_ = dDividerGap
+  Set factors_ = New Scripting.Dictionary
+  Set values_ = New Scripting.Dictionary
+End Function
+
+Public Property Get Values() As Scripting.Dictionary
+  Set Values = values_
+End Property
+
+Public Function Insert(vNewItem As Variant, dValue As Double) As Boolean
+  Insert = Not values_.Exists(vNewItem)
+  If Not Insert Then _
+    Exit Function
+
+  values_(vNewItem) = dValue
+  factors_(vNewItem) = vNewItem
+  If values_.Count = 1 Then _
+    Exit Function
+  
+  Dim vItem As Variant
+  For Each vItem In values_
+    If vItem = vNewItem Then _
+      GoTo NEXT_ITEM
+    If VBA.Abs(values_(vItem) - dValue) > gap_ Then _
+      GoTo NEXT_ITEM
+    
+    If FactorValueFor(vItem) >= FactorValueFor(vNewItem) Then
+      Call MergeFactors(factors_(vNewItem), factors_(vItem))
+    Else
+      Call MergeFactors(factors_(vItem), factors_(vNewItem))
+    End If
+NEXT_ITEM:
+  Next vItem
+End Function
+
+Public Function FactorFor(vItem As Variant) As Variant
+  If values_.Exists(vItem) Then _
+    FactorFor = factors_(vItem)
+End Function
+
+Public Function FactorValueFor(vItem As Variant) As Double
+  If values_.Exists(vItem) Then _
+    FactorValueFor = values_(factors_(vItem))
+End Function
+
+' =====
+Private Function MergeFactors(vOld As Variant, vNew As Variant)
+  Dim vItem As Variant
+  For Each vItem In factors_
+    If factors_(vItem) = vOld Then _
+      factors_(vItem) = vNew
+  Next vItem
+End Function

utility/CDS_Graph.cls

@@ -0,0 +1,172 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "CDS_Graph"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ====== Class Module for Graph management ========
+' Shared module version: 20210419
+' Tested in: TestCommons
+' Depends on: ex_Collection, CDS_Edge, CDS_Node
+' Required reference: Scripting
+' Warning: node data should be basic type and be convertible to String (VBA.CStr)
+Option Explicit
+
+Public nodes_ As Scripting.Dictionary
+Public edges_ As Scripting.Dictionary
+
+Private Sub Class_Initialize()
+  Call Clear
+End Sub
+
+Public Function Clear()
+  Set nodes_ = New Scripting.Dictionary
+  Set edges_ = New Scripting.Dictionary
+End Function
+
+Public Property Get Size() As Long
+  Size = nodes_.Count
+End Property
+
+Public Property Get Nodes() As Collection
+  Set Nodes = New Collection
+  Dim vData As Variant
+  For Each vData In nodes_
+    Call Nodes.Add(vData)
+  Next vData
+End Property
+
+Public Function AddNode(vNode As Variant)
+  Call InternalAddNode(vNode)
+End Function
+
+Public Function HasNode(vNode As Variant) As Boolean
+  HasNode = nodes_.Exists(vNode)
+End Function
+
+Public Function AddEdge(vSource As Variant, vDestination As Variant) As CDS_Edge
+  Call AddNode(vSource)
+  Call AddNode(vDestination)
+  
+  Dim newEdge As New CDS_Edge: Call newEdge.Init(vSource, vDestination)
+  Dim sEdge$: sEdge = newEdge.ID
+  
+  If edges_.Exists(sEdge) Then _
+    Exit Function
+
+  Call edges_.Add(sEdge, newEdge)
+  Call nodes_(vSource).outputs_.Add(vDestination)
+  Call nodes_(vDestination).inputs_.Add(vSource)
+  
+  Set AddEdge = newEdge
+End Function
+
+Public Function HasEdge(vSource As Variant, vDestination As Variant) As Boolean
+  Dim newEdge As New CDS_Edge: Call newEdge.Init(vSource, vDestination)
+  Dim sEdge$: sEdge = newEdge.ID
+  HasEdge = edges_.Exists(sEdge)
+End Function
+
+Public Function ExpandOutputs(ByRef target As Scripting.Dictionary)
+  Dim nCount&
+  Do While True
+    nCount = target.Count
+    Call ExpandOutsOnce(target)
+    If nCount = target.Count Then _
+      Exit Function
+  Loop
+End Function
+
+Public Function ExpandInputs(ByRef target As Scripting.Dictionary)
+  Dim nCount&
+  Do While True
+    nCount = target.Count
+    Call ExpandInsOnce(target)
+    If nCount = target.Count Then _
+      Exit Function
+  Loop
+End Function
+
+Public Function ExpandBiderctional(ByRef target As Scripting.Dictionary)
+  Dim nCount&
+  Do While True
+    nCount = target.Count
+    Call ExpandBiderctionalOnce(target)
+    If nCount = target.Count Then _
+      Exit Function
+  Loop
+End Function
+
+Public Function ExpandOutsOnce(ByRef target As Scripting.Dictionary)
+  Dim nCount&: nCount = target.Count
+  Dim aKey As Variant
+  Dim vChild As Variant
+  For Each aKey In target
+    For Each vChild In nodes_(aKey).outputs_
+      If Not target.Exists(vChild) Then _
+        Call target.Add(vChild, 0)
+    Next vChild
+    nCount = nCount - 1
+    If nCount = 0 Then _
+      Exit Function
+  Next aKey
+End Function
+
+Public Function ExpandInsOnce(ByRef target As Scripting.Dictionary)
+  Dim nCount&: nCount = target.Count
+  Dim aKey As Variant
+  Dim vChild As Variant
+  For Each aKey In target
+    For Each vChild In nodes_(aKey).inputs_
+      If Not target.Exists(vChild) Then _
+        Call target.Add(vChild, 0)
+    Next vChild
+    nCount = nCount - 1
+    If nCount = 0 Then _
+      Exit Function
+  Next aKey
+End Function
+
+Public Function ExpandBiderctionalOnce(ByRef target As Scripting.Dictionary, Optional nStart& = 1)
+  Dim nCount&: nCount = target.Count
+  Dim aKey As Variant
+  Dim vChild As Variant
+  For Each aKey In target
+    For Each vChild In nodes_(aKey).inputs_
+      If Not target.Exists(vChild) Then _
+        Call target.Add(vChild, 0)
+    Next vChild
+    For Each vChild In nodes_(aKey).outputs_
+      If Not target.Exists(vChild) Then _
+        Call target.Add(vChild, 0)
+    Next vChild
+    nCount = nCount - 1
+    If nCount = 0 Then _
+      Exit Function
+  Next aKey
+End Function
+
+Public Function FilterInternalEdges(iNodes As Scripting.Dictionary) As Collection
+  Dim iEdges As New Collection
+  Dim anEdge As CDS_Edge
+  Dim aKey As Variant
+  For Each aKey In edges_
+    Set anEdge = edges_(aKey)
+    If iNodes.Exists(anEdge.source_) And iNodes.Exists(anEdge.dest_) Then _
+      Call iEdges.Add(anEdge)
+  Next aKey
+  Set FilterInternalEdges = iEdges
+End Function
+
+' ==============
+Private Function InternalAddNode(vNode As Variant)
+  If nodes_.Exists(vNode) Then _
+    Exit Function
+
+  Dim newNode As New CDS_Node
+  newNode.data_ = vNode
+  Call nodes_.Add(vNode, newNode)
+End Function

utility/CDS_Interval.cls

@@ -0,0 +1,34 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "CDS_Interval"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ======== Ìîäóëü-èíòåðâàë =============
+' Shared module version: 20210430
+' Tested in: TestCommons
+' Depends on:
+' Required reference:
+Option Explicit
+
+Public start_ As Long
+Public finish_ As Long
+
+Public Function Init(nStart&, nFinish&)
+  start_ = nStart
+  finish_ = nFinish
+End Function
+
+Public Function Clone() As CDS_Interval
+  Set Clone = New CDS_Interval
+  Call Clone.Init(start_, finish_)
+End Function
+
+Public Function Compare(rhs As Variant) As Double
+  Compare = start_ - rhs.start_
+  If Compare = 0 Then _
+    Compare = finish_ - rhs.finish_
+End Function

utility/CDS_Node.cls

@@ -0,0 +1,19 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "CDS_Node"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ========= Class Module for Graph node =======
+' Shared module version: 20210409
+' Tested in: TestCommons
+' Depends on:
+' Required reference:
+Option Explicit
+
+Public data_ As Variant
+Public outputs_ As New Collection
+Public inputs_ As New Collection

utility/CDS_NodeSH.cls

@@ -0,0 +1,33 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "CDS_NodeSH"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' =============== Static hierarchy Node =====================
+' Shared module version: 20210430
+' Tested in: TestCommons
+' Depends on:
+' Required reference:
+Option Explicit
+
+Public id_ As Long
+Public rank_ As Long
+Public parent_ As CDS_NodeSH
+Public children_ As Collection ' of CDS_NodeSH
+Public descendantsCount_ As Long
+
+Public data_ As Object ' Payload should be filled in by the caller
+
+Private Sub Class_Initialize()
+  Set children_ = New Collection
+  descendantsCount_ = 0
+End Sub
+
+Public Function Init(nID&, nRank&)
+  id_ = nID
+  rank_ = nRank
+End Function

utility/CDS_StaticHierarchy.cls

@@ -0,0 +1,78 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "CDS_StaticHierarchy"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ================= Static hierarchy =======================
+' Shared module version: 20210518
+' Tested in: TestCommons
+' Depends on: CDS_NodeSH
+' Required reference: Scripting
+' =========
+' Example of valid structure
+' 1
+' 1.1
+' 1.2
+' 1.2.1
+' 1.2.1.1
+' 1.3
+' 2
+' 0
+' ======
+' Example of invalid structure ( increase level > 1 )
+' 1
+' 1.1.3
+Option Explicit
+
+Public nodes_ As Collection
+
+Private levels_ As Scripting.Dictionary
+Private previousRank_ As Long
+
+Private Sub Class_Initialize()
+  Set nodes_ = New Collection
+  Set levels_ = New Scripting.Dictionary
+  previousRank_ = -1
+End Sub
+
+Public Property Get MaxDepth() As Long
+  MaxDepth = levels_.Count
+End Property
+
+Public Property Get Size() As Long
+  Size = nodes_.Count
+End Property
+
+' Requires nRank <= previousLevel + 1
+Public Function PushItem(nRank&) As CDS_NodeSH
+  If nodes_.Count > 0 Then
+    If previousRank_ < nRank Then _
+      If previousRank_ <> nRank - 1 Then _
+        Exit Function
+  End If
+      
+  Dim iNewNode As New CDS_NodeSH: Call iNewNode.Init(nodes_.Count + 1, nRank)
+  Set levels_(nRank) = iNewNode
+  previousRank_ = nRank
+  If levels_.Exists(nRank - 1) Then
+    Set iNewNode.parent_ = levels_(nRank - 1)
+    Call levels_(nRank - 1).children_.Add(iNewNode)
+    Call IncrementDescendants(nRank - 1)
+  End If
+  
+  Call nodes_.Add(iNewNode)
+  Set PushItem = iNewNode
+End Function
+
+' =======
+Private Function IncrementDescendants(nTarget&)
+  Dim nRank As Variant
+  For Each nRank In levels_
+    If nRank <= nTarget Then _
+      levels_(nRank).descendantsCount_ = levels_(nRank).descendantsCount_ + 1
+  Next nRank
+End Function

utility/ex_Collection.bas

@@ -0,0 +1,138 @@
+Attribute VB_Name = "ex_Collection"
+' ======= Collection functions extensions ===============
+' Shared module version: 20210708
+' Tested in: TestCommons
+' Depends on:
+' Required reference: Scripting
+Option Private Module
+Option Explicit
+
+Public Function InCollection(sKey$, coll As Collection) As Boolean
+  On Error GoTo RESTORE_ERR
+  Call coll.Item(sKey)
+  InCollection = True
+  Exit Function
+  
+RESTORE_ERR:
+  InCollection = False
+End Function
+
+' Returns dictionary of indicies of first occurence for every element in array @aSource
+' Note: duplicate elements are ignored
+Public Function CollectionToIndex(iSource As Collection) As Scripting.Dictionary
+  Dim indicies As New Scripting.Dictionary
+  Dim val As Variant
+  Dim nIndex&: nIndex = 1
+  For Each val In iSource
+    If Not indicies.Exists(val) Then _
+      Call indicies.Add(val, nIndex)
+    nIndex = nIndex + 1
+  Next val
+  Set CollectionToIndex = indicies
+End Function
+
+Public Function RevertCollection(target As Collection) As Collection
+  Set RevertCollection = New Collection
+  Dim nItem&
+  For nItem = target.Count To 1 Step -1
+    Call RevertCollection.Add(target.Item(nItem))
+  Next nItem
+End Function
+
+Public Function IsSubsetOf(target As Collection, superset As Collection) As Boolean
+  IsSubsetOf = False
+  
+  If target Is Nothing Or superset Is Nothing Then _
+    Exit Function
+  
+  Dim val As Variant
+  For Each val In target
+    If Not InCollection(CStr(val), superset) Then _
+      Exit Function
+  Next val
+  
+  IsSubsetOf = True
+End Function
+
+Public Function SafeAddToCollection(aValue As Variant, sKey$, coll As Collection) As Boolean
+' Äîáàâëåíèå â êîëëíåöèþ - âîçâðàùàåò False åñëè óæå åñòü
+  On Error GoTo ON_ERROR
+  Call coll.Add(aValue, sKey)
+  SafeAddToCollection = True
+  Exit Function
+  
+ON_ERROR:
+  SafeAddToCollection = False
+End Function
+
+Public Function SafeMergeCollection(cSource As Collection, cDestination As Collection) As Boolean
+  SafeMergeCollection = False
+  
+  If cSource Is Nothing Or cDestination Is Nothing Then _
+    Exit Function
+    
+  Dim val As Variant
+  For Each val In cSource
+    Call SafeAddToCollection(CStr(val), CStr(val), cDestination)
+  Next val
+  
+  SafeMergeCollection = True
+End Function
+
+Public Function ToArray(cSource As Collection) As Variant
+  If cSource Is Nothing Then _
+    Exit Function
+    
+  Dim arResult() As Variant
+  If cSource.Count > 0 Then
+    ReDim arResult(0 To cSource.Count - 1)
+    Dim i&
+    For i = 0 To cSource.Count - 1
+      arResult(i) = cSource(i + 1)
+    Next i
+  Else
+    ReDim arResult(0 To 0)
+  End If
+  ToArray = arResult()
+End Function
+
+Public Function ToLongArray(cSource As Collection) As Long()
+  If cSource Is Nothing Then _
+    Exit Function
+    
+  Dim arResult() As Long
+  If cSource.Count > 0 Then
+    ReDim arResult(0 To cSource.Count - 1)
+    Dim i&
+    For i = 0 To cSource.Count - 1
+      arResult(i) = cSource(i + 1)
+    Next i
+  Else
+    ReDim arResult(0 To 0)
+  End If
+  ToLongArray = arResult()
+End Function
+
+Public Function FromArray(aSource As Variant) As Collection
+  If Not IsArrayAllocated(aSource) Then _
+    Exit Function
+  Dim cResult As New Collection
+  Dim val As Variant
+  If UBound(aSource) <> LBound(aSource) Then
+    For Each val In aSource
+      Call cResult.Add(val)
+    Next val
+  End If
+  Set FromArray = cResult
+End Function
+
+Public Function CollectionToLines(target As Collection) As String
+  If target Is Nothing Then _
+    Exit Function
+  Dim anItem As Variant
+  For Each anItem In target
+    If CollectionToLines <> vbNullString Then _
+      CollectionToLines = CollectionToLines & vbNewLine
+    CollectionToLines = CollectionToLines & CStr(anItem)
+  Next anItem
+End Function

utility/ex_Color.bas

@@ -0,0 +1,298 @@
+Attribute VB_Name = "ex_Color"
+'================ Ìîäóëü äëÿ ðàáîòû ñ öâåòàìè â ðàçíûõ ïðèëîæåíèÿõ =============
+' Shared module version: 20210430
+' Tested in: TestCommons
+' Depends on:
+' Required reference:
+Option Private Module
+Option Explicit
+
+Public Enum ColorType
+  CT_RGB = &H0
+  CT_AUTO = &HFF
+  CT_SYSTEM = &H80
+  CT_THEME_LOW = &HD0
+  CT_THEME_HIGH = &HDF
+End Enum
+
+Public Type ColorDetails
+  type_  As Byte
+  clrIndex_ As WdThemeColorIndex
+  tintShade_  As Double
+  rgb_ As Long
+End Type
+
+Public Enum HardColor
+  HC_INVALID = -1
+  HC_WHITE = &HFFFFFF
+  HC_BLACK = &H0
+  HC_RED = &HFF
+  HC_GREEN = &HFF00
+  HC_BLUE = &HFF0000
+End Enum
+
+Public Declare PtrSafe Function _
+  ColorAdjustLuma Lib "shlwapi.dll" ( _
+    ByVal nRGB As Long, _
+    ByVal nLumaAdjust As Long, _
+    ByVal bScale As Long) As Long
+
+Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
+
+Private Enum AppType
+  T_APP_UNDEF = 0
+  [_First] = 1
+  
+  T_APP_WORD = 1
+  T_APP_EXCEL = 2
+  T_APP_VISIO = 3
+  T_APP_POWER_POINT = 4
+
+  [_Last] = 4
+End Enum
+
+Public Function ColorGetLuma(nRGB&) As Long
+  Dim clrRed%, clrGreen%, clrBlue%
+  Call LongColor3Components(nRGB, clrRed, clrGreen, clrBlue)
+  ColorGetLuma = Math_Sym(0.2126 * clrRed + 0.7152 * clrGreen + 0.0722 * clrBlue)
+End Function
+
+Public Function ColorGetRGB(nColorID&, aDocument As Object) As Long
+  ColorGetRGB = QueryColor(nColorID, aDocument).rgb_
+End Function
+
+Public Function ConvertRGBtoString(nRGB&) As String
+  Dim nRed%, nGreen%, nBlue%
+  Call LongColor3Components(nRGB, nRed, nGreen, nBlue)
+  ConvertRGBtoString = "RGB(" & nRed & "," & nGreen & "," & nBlue & ")"
+End Function
+
+Public Function ConvertStringToRGB(sColor$) As Long
+  ConvertStringToRGB = HC_INVALID
+  
+  Dim nLen&: nLen = VBA.Len(sColor)
+  Dim nPos&: nPos = 1
+  Dim nRed%: nRed = ExtractFirstInteger(sColor, nPos)
+  If nPos > nLen Or nRed = HC_INVALID Or nRed > 255 Then _
+    Exit Function
+    
+  nPos = nPos + 1
+  Dim nGreen%: nGreen = ExtractFirstInteger(sColor, nPos)
+  If nPos > nLen Or nGreen = HC_INVALID Or nGreen > 255 Then _
+    Exit Function
+    
+  nPos = nPos + 1
+  Dim nBlue%: nBlue = ExtractFirstInteger(sColor, nPos)
+  If nPos > nLen Or nBlue = HC_INVALID Or nBlue > 255 Then _
+    Exit Function
+  
+  ConvertStringToRGB = RGB(nRed, nGreen, nBlue)
+End Function
+
+Public Function QueryColor(nColorID&, aDocument As Object) As ColorDetails
+  Dim sHexColor$: sHexColor = VBA.Right$(VBA.String$(7, "0") & VBA.Hex$(nColorID), 8)
+  QueryColor.type_ = CByte("&H" & VBA.Left$(sHexColor, 2))
+  Select Case QueryColor.type_
+    Case CT_RGB: QueryColor.rgb_ = nColorID
+    Case CT_SYSTEM: QueryColor.rgb_ = SysColorToRGB(nColorID)
+    Case CT_THEME_LOW To CT_THEME_HIGH: QueryColor = QueryThemeColor(QueryColor.type_, sHexColor, aDocument)
+  End Select
+End Function
+
+' =========
+Private Function LongColor3Components(nColor&, ByRef c1%, ByRef c2%, ByRef c3%)
+  c1 = Math_Sym(nColor And &HFF&)
+  c2 = Math_Sym((nColor And &HFF00&) / &H100&)
+  c3 = Math_Sym((nColor And &HFF0000) / &H10000)
+End Function
+
+Private Function Math_Sym(ByVal nValue As Double, Optional ByVal dFactor As Double = 1) As Double
+   Math_Sym = Fix(nValue * dFactor + 0.5 * Sgn(nValue)) / dFactor
+End Function
+
+Private Function ExtractApplicationType(target As Object) As AppType
+  If target Is Nothing Then
+    ExtractApplicationType = T_APP_UNDEF
+    Exit Function
+  End If
+  Select Case target.Application.Name
+    Case "Microsoft Word":      ExtractApplicationType = T_APP_WORD
+    Case "Microsoft Excel":     ExtractApplicationType = T_APP_EXCEL
+    Case "Microsoft PowerPoint":  ExtractApplicationType = T_APP_POWER_POINT
+    Case "Microsoft Visio": ExtractApplicationType = T_APP_VISIO
+    Case Else: ExtractApplicationType = T_APP_UNDEF
+  End Select
+End Function
+
+Private Function ExtractFirstInteger(sText$, ByRef nPos&) As Integer
+  On Error GoTo ERR_OVERFLOW
+
+  Dim bStarted As Boolean: bStarted = False
+  Dim nLen&: nLen = VBA.Len(sText)
+  Dim sDigit$
+  Do
+    If nPos > nLen Then _
+      Exit Function
+    sDigit = VBA.Mid(sText, nPos, 1)
+    If VBA.IsNumeric(sDigit) Then
+      bStarted = True
+      ExtractFirstInteger = ExtractFirstInteger * 10 + VBA.CLng(sDigit)
+    ElseIf bStarted Then _
+      Exit Function
+    End If
+    nPos = nPos + 1
+  Loop
+  
+ERR_OVERFLOW:
+  On Error GoTo 0
+  ExtractFirstInteger = HC_INVALID
+End Function
+
+Private Function SysColorToRGB(nColor&) As Long
+  SysColorToRGB = GetSysColor(nColor And &HFFFFFF)
+End Function
+
+Private Function QueryThemeColor(clrType As Byte, hexColor$, aDocument As Object) As ColorDetails
+  QueryThemeColor.type_ = clrType And &HF0
+  QueryThemeColor.clrIndex_ = clrType And &HF
+  
+  Dim bDarkness As Byte: bDarkness = CByte("&H" & Mid$(hexColor, 5, 2))
+  If bDarkness <> &HFF Then
+    QueryThemeColor.tintShade_ = VBA.Round(-1 + bDarkness / &HFF, 2)
+  End If
+  
+  Dim bLightness As Byte: bLightness = CByte("&H" & Mid$(hexColor, 7, 2))
+  If bLightness <> &HFF Then
+    QueryThemeColor.tintShade_ = VBA.Round(1 - bLightness / &HFF, 2)
+  End If
+
+  QueryThemeColor.rgb_ = GetThemeRGB(QueryThemeColor.clrIndex_, QueryThemeColor.tintShade_, aDocument)
+End Function
+
+Private Function GetThemeRGB(clrIndex As WdThemeColorIndex, tintShade As Double, aDocument As Object) As Long
+  Dim schemeID  As MsoThemeColorSchemeIndex
+  Dim schemeRGB&
+  Select Case ExtractApplicationType(aDocument)
+    Case T_APP_UNDEF
+      schemeID = WordColor(clrIndex)
+      schemeRGB = ActiveDocument.DocumentTheme.ThemeColorScheme(schemeID).RGB
+    Case T_APP_WORD
+      schemeID = WordColor(clrIndex)
+      schemeRGB = aDocument.DocumentTheme.ThemeColorScheme(schemeID).RGB
+    Case T_APP_VISIO
+      schemeRGB = aDocument.DocumentTheme.ThemeColorScheme(clrIndex).RGB
+    Case T_APP_EXCEL
+      schemeID = ExcelColor(clrIndex)
+      schemeRGB = aDocument.DocumentTheme.ThemeColorScheme(schemeID).RGB
+    Case T_APP_POWER_POINT
+      schemeRGB = aDocument.DocumentTheme.ThemeColorScheme(clrIndex).RGB
+  End Select
+  GetThemeRGB = ColorAdjustLuma(schemeRGB, Math_Sym(tintShade, 1000) * 1000, True)
+End Function
+ 
+Private Function WordColor(clrID As WdThemeColorIndex) As MsoThemeColorSchemeIndex
+  Select Case clrID
+    Case wdThemeColorMainDark1:         WordColor = msoThemeDark1
+    Case wdThemeColorMainLight1:        WordColor = msoThemeLight1
+    Case wdThemeColorMainDark2:         WordColor = msoThemeDark2
+    Case wdThemeColorMainLight2:        WordColor = msoThemeLight2
+    Case wdThemeColorAccent1:           WordColor = msoThemeAccent1
+    Case wdThemeColorAccent2:           WordColor = msoThemeAccent2
+    Case wdThemeColorAccent3:           WordColor = msoThemeAccent3
+    Case wdThemeColorAccent4:           WordColor = msoThemeAccent4
+    Case wdThemeColorAccent5:           WordColor = msoThemeAccent5
+    Case wdThemeColorAccent6:           WordColor = msoThemeAccent6
+    Case wdThemeColorHyperlink:         WordColor = msoThemeHyperlink
+    Case wdThemeColorHyperlinkFollowed: WordColor = msoThemeFollowedHyperlink
+    Case wdThemeColorBackground1:       WordColor = msoThemeLight1
+    Case wdThemeColorText1:             WordColor = msoThemeDark1
+    Case wdThemeColorBackground2:       WordColor = msoThemeLight2
+    Case wdThemeColorText2:             WordColor = msoThemeDark2
+    Case Else:
+  End Select
+End Function
+
+Private Function ExcelColor(clrID As XlThemeColor) As MsoThemeColorSchemeIndex
+  Select Case clrID
+    Case xlThemeColorDark1:               ExcelColor = msoThemeDark1
+    Case xlThemeColorLight1:              ExcelColor = msoThemeLight1
+    Case xlThemeColorDark2:               ExcelColor = msoThemeDark2
+    Case xlThemeColorLight2:              ExcelColor = msoThemeLight2
+    Case xlThemeColorAccent1:             ExcelColor = msoThemeAccent1
+    Case xlThemeColorAccent2:             ExcelColor = msoThemeAccent2
+    Case xlThemeColorAccent3:             ExcelColor = msoThemeAccent3
+    Case xlThemeColorAccent4:             ExcelColor = msoThemeAccent4
+    Case xlThemeColorAccent5:             ExcelColor = msoThemeAccent5
+    Case xlThemeColorAccent6:             ExcelColor = msoThemeAccent6
+    Case xlThemeColorHyperlink:           ExcelColor = msoThemeHyperlink
+    Case xlThemeColorFollowedHyperlink:   ExcelColor = msoThemeFollowedHyperlink
+    Case Else:
+  End Select
+End Function
+
+'
+'
+''----------------------Êîíâåðòèðîâàíèå ------------------------------------------------
+'Function Convert_RGB2CMYK(colr&) As Long
+''RGB -> CMYK
+'  Dim red As Integer, blue As Integer, green As Integer
+'  Dim c As Double, m As Double, y As Double, k As Double, minCMY As Double
+'  Dim cyan As Integer, magenta As Integer, yellow As Integer, key As Integer
+'
+'  Call LongColor3Components(colr, red, green, blue)
+'  If red = 0 And green = 0 And blue = 0 Then
+'    key = 100
+'    GoTo RESULTING
+'  End If
+'
+'  c = 1 - (red / 255)
+'  m = 1 - (green / 255)
+'  y = 1 - (blue / 255)
+'  k = Math_Min(c, Math_Min(m, y))
+'
+'  cyan = Math_Sym(100 * (c - k) / (1 - k))
+'  magenta = Math_Sym(100 * (m - k) / (1 - k))
+'  yellow = Math_Sym(100 * (y - k) / (1 - k))
+'  key = Math_Sym(100 * k)
+'
+'RESULTING:
+'  Convert_RGB2CMYK = cyan * 101 ^ 3 + 101 ^ 2 * magenta + 101 * yellow + key
+'End Function
+'
+'
+''--------------------------Îáðàáîòêà öâåòîâûõ ññûëîê ------------------------
+'
+'Private Function SysColorToRGB(ByVal SysColor&) As Long
+''Âîçâðàùàåò RGB ñèñòåìíîãî öâåòà
+'  SysColor = SysColor And &HFFFFFF
+'  SysColorToRGB = GetSysColor(SysColor)
+'End Function
+'
+'Private Function QueryThemeColor(ColourTypeByte As Byte, _
+'                 ColourToTestHex As String, app As Object) _
+'         As ColorDetails
+'
+'  Const Unchanged    As Byte = &HFF
+'
+'  Dim LightnessByte  As Byte
+'  Dim DarknessByte   As Byte
+'
+'  LightnessByte = CByte("&H" & Mid$(ColourToTestHex, 7, 2))
+'  DarknessByte = CByte("&H" & Mid$(ColourToTestHex, 5, 2))
+'
+'  QueryThemeColor.ColourType = ColourTypeByte And &HF0
+'  QueryThemeColor.ThemeColorIndex = ColourTypeByte And &HF
+'
+'  If DarknessByte <> Unchanged Then
+'    QueryThemeColor.TintAndShade = Round(-1 + DarknessByte / &HFF, 2)
+'  End If
+'
+'  If LightnessByte <> Unchanged Then
+'    QueryThemeColor.TintAndShade = Round(1 - LightnessByte / &HFF, 2)
+'  End If
+'
+'  QueryThemeColor.RGB = GetThemeRGB(QueryThemeColor.ThemeColorIndex, _
+'                 QueryThemeColor.TintAndShade, app)
+'
+'End Function
+

utility/ex_DataPreparation.bas

@@ -0,0 +1,345 @@
+Attribute VB_Name = "ex_DataPreparation"
+' ======== Data manipulation tools ============
+' Shared module version: 20220217
+' Depends on:
+' Required reference:
+Option Private Module
+Option Explicit
+
+Public Function ApplyCommonAbbreviations(sText$) As String
+  Dim sResult$: sResult = sText
+  
+  sResult = VBA.Replace(sResult, Chr(9), " ")
+  sResult = VBA.Replace(sResult, Chr(160), " ")
+  
+  sResult = VBA.Replace(sResult, "(с изменениями и дополнениями)", "")
+  sResult = VBA.Replace(sResult, "  ", " ")
+  
+  sResult = VBA.Replace(sResult, "Российская Федерация", "РФ")
+  sResult = VBA.Replace(sResult, "Россия", "РФ")
+  sResult = VBA.Replace(sResult, "Федеральный закон", "ФЗ")
+  sResult = VBA.Replace(sResult, "Постановление Правительства", "ПП")
+  sResult = VBA.Replace(sResult, "Распоряжение Правительства", "РП")
+  
+  sResult = VBA.Replace(sResult, "Российской Федерации", "РФ")
+  sResult = VBA.Replace(sResult, "России", "РФ")
+  sResult = VBA.Replace(sResult, "Федерального закона", "ФЗ")
+  sResult = VBA.Replace(sResult, "Постановления Правительства", "ПП")
+  sResult = VBA.Replace(sResult, "Распоряжения Правительства", "РП")
+  
+  sResult = VBA.Replace(sResult, "Министерство внутренних дел", "МВД")
+  sResult = VBA.Replace(sResult, "Министерство иностранных дел", "МИД")
+  sResult = VBA.Replace(sResult, "Министерство обороны", "Минобороны")
+  sResult = VBA.Replace(sResult, "Министерство юстиции", "Минюст")
+  sResult = VBA.Replace(sResult, "Министерство здравоохранения", "Минздрав")
+  sResult = VBA.Replace(sResult, "Министерство культуры", "Минкультуры")
+  sResult = VBA.Replace(sResult, "Министерство образования и науки", "Минобрнауки")
+  sResult = VBA.Replace(sResult, "Министерство природных ресурсов и экологии", "Минприроды")
+  sResult = VBA.Replace(sResult, "Министерство промышленности и торговли", "Минпромторг")
+  sResult = VBA.Replace(sResult, "Министерство Российской Федерации по развитию Дальнего Востока", "Минвостокразвития РФ")
+  sResult = VBA.Replace(sResult, "Министерство регионального развития", "Минрегион")
+  sResult = VBA.Replace(sResult, "Министерство связи и массовых коммуникаций", "Минкомсвязь")
+  sResult = VBA.Replace(sResult, "Министерство сельского хозяйства", "Минсельхоз")
+  sResult = VBA.Replace(sResult, "Министерство спорта", "Минспорт")
+  sResult = VBA.Replace(sResult, "Министерство транспорта", "Минтранса")
+  sResult = VBA.Replace(sResult, "Министерство труда и социальной защиты", "Минтруд")
+  sResult = VBA.Replace(sResult, "Министерство финансов", "Минфин")
+  sResult = VBA.Replace(sResult, "Министерство экономического развития", "Минэкономразвития")
+  sResult = VBA.Replace(sResult, "Министерство энергетики", "Минэнерго")
+  sResult = VBA.Replace(sResult, "Министерство строительства и жилищно-коммунального хозяйства", "Минстрой")
+  
+  sResult = VBA.Replace(sResult, "Министерства внутренних дел", "МВД")
+  sResult = VBA.Replace(sResult, "Министерства иностранных дел", "МИД")
+  sResult = VBA.Replace(sResult, "Министерства обороны", "Минобороны")
+  sResult = VBA.Replace(sResult, "Министерства юстиции", "Минюста")
+  sResult = VBA.Replace(sResult, "Министерства здравоохранения", "Минздрава")
+  sResult = VBA.Replace(sResult, "Министерства культуры", "Минкультуры")
+  sResult = VBA.Replace(sResult, "Министерства образования и науки", "Минобрнауки")
+  sResult = VBA.Replace(sResult, "Министерства природных ресурсов и экологии", "Минприроды")
+  sResult = VBA.Replace(sResult, "Министерства промышленности и торговли", "Минпромторга")
+  sResult = VBA.Replace(sResult, "Министерства Российской Федерации по развитию Дальнего Востока", "Минвостокразвития РФ")
+  sResult = VBA.Replace(sResult, "Министерства регионального развития", "Минрегиона")
+  sResult = VBA.Replace(sResult, "Министерства связи и массовых коммуникаций", "Минкомсвязи")
+  sResult = VBA.Replace(sResult, "Министерства сельского хозяйства", "Минсельхоза")
+  sResult = VBA.Replace(sResult, "Министерства спорта", "Минспорта")
+  sResult = VBA.Replace(sResult, "Министерства транспорта", "Минтранса")
+  sResult = VBA.Replace(sResult, "Министерства труда и социальной защиты", "Минтруда")
+  sResult = VBA.Replace(sResult, "Министерства финансов", "Минфина")
+  sResult = VBA.Replace(sResult, "Министерства экономического развития", "Минэкономразвития")
+  sResult = VBA.Replace(sResult, "Министерства энергетики", "Минэнерго")
+  sResult = VBA.Replace(sResult, "Министерства строительства и жилищно-коммунального хозяйства", "Минстроя")
+  
+  sResult = VBA.Replace(sResult, "Федеральная служба по техническому и экспортному контролю", "ФСТЭК")
+  sResult = VBA.Replace(sResult, "Федеральная служба безопасности", "ФСБ")
+  sResult = VBA.Replace(sResult, "Федеральная служба Российской Федерации по контролю за оборотом наркотиков", "ФСКН РФ")
+  sResult = VBA.Replace(sResult, "Федеральная служба охраны", "ФСО")
+  sResult = VBA.Replace(sResult, "Федеральная служба по гидрометеорологии и мониторингу окружающей среды", "Росгидромет")
+  sResult = VBA.Replace(sResult, "Федеральная служба по экологическому, технологическому и атомному надзору", "Ростехнадзор")
+  sResult = VBA.Replace(sResult, "Федеральная служба по надзору в сфере природопользования", "Росприроднадзор")
+  sResult = VBA.Replace(sResult, "Федеральная служба по ветеринарному и фитосанитарному надзору", "Россельхознадзор")
+  sResult = VBA.Replace(sResult, "Федеральная служба по надзору в сфере транспорта", "Ространснадзор")
+  sResult = VBA.Replace(sResult, "Федеральная служба по труду и занятости", "Роструд")
+  sResult = VBA.Replace(sResult, "Федеральная служба по регулированию алкогольного рынка", "Росалкогольрегулирование")
+  sResult = VBA.Replace(sResult, "Федеральная служба по надзору в сфере связи, информационных технологий и массовых коммуникаций", "Роскомнадзор")
+  sResult = VBA.Replace(sResult, "Федеральная служба по аккредитации", "Росаккредитация")
+  sResult = VBA.Replace(sResult, "Федеральная служба государственной статистики", "Росстат")
+  sResult = VBA.Replace(sResult, "Федеральная служба по интеллектуальной собственности", "Роспатент")
+  sResult = VBA.Replace(sResult, "Федеральная служба по финансовому мониторингу", "Росфинмониторинг")
+  sResult = VBA.Replace(sResult, "Федеральная служба государственной регистрации, кадастра и картографии", "Росреестр")
+  sResult = VBA.Replace(sResult, "Федеральная служба по надзору в сфере защиты прав потребителей и благополучия человека", "Роспотребнадзор")
+  sResult = VBA.Replace(sResult, "Федеральная служба по надзору в сфере здравоохранения", "Росздравнадзор")
+  sResult = VBA.Replace(sResult, "Федеральная служба по надзору в сфере образования и науки", "Рособзнадзор")
+  sResult = VBA.Replace(sResult, "Федеральная служба по экологическому, технологическому и атомному надзору", "Ростехнадзор")
+  sResult = VBA.Replace(sResult, "Федеральное агентство по техническому регулированию и метрологии", "Росстандарт")
+  sResult = VBA.Replace(sResult, "Федеральное агентство водных ресурсов", "Росводресурсы")
+  sResult = VBA.Replace(sResult, "Федеральное агентство лесного хозяйства", "Рослесхоз")
+  sResult = VBA.Replace(sResult, "Федеральное агентство по недропользованию", "Роснедра")
+  sResult = VBA.Replace(sResult, "Федеральное агентство по рыболовству", "Росрыболовство")
+  sResult = VBA.Replace(sResult, "Федеральное агентство воздушного транспорта", "Росавиация")
+  sResult = VBA.Replace(sResult, "Федеральное агентство железнодорожного транспорта", "Росжелдор")
+  sResult = VBA.Replace(sResult, "Федеральное агентство морского и речного транспорта", "Росморречфлот")
+  sResult = VBA.Replace(sResult, "Федеральное агентство по управлению государственным имуществом", "Росимущество")
+  sResult = VBA.Replace(sResult, "Федеральное агентство по печати и массовым коммуникациям", "Роспечать")
+  sResult = VBA.Replace(sResult, "Федеральное агентство связи", "Россвязь")
+  sResult = VBA.Replace(sResult, "Федеральное агентство по туризму", "Ростуризм")
+  sResult = VBA.Replace(sResult, "Федеральное агентство по государственным резервам", "Росрезерв")
+  sResult = VBA.Replace(sResult, "Федеральное агентство по делам молодёжи", "Росмолодёжь")
+  sResult = VBA.Replace(sResult, "Федеральное агентство по делам национальностей", "ФАДН")
+  sResult = VBA.Replace(sResult, "Федеральная налоговая служба", "ФНС")
+  sResult = VBA.Replace(sResult, "Федеральная таможенная служба", "ФТС")
+  sResult = VBA.Replace(sResult, "Государственная фельдъегерская служба", "ГФС")
+  sResult = VBA.Replace(sResult, "Федеральная антимонопольная служба", "ФАС")
+  sResult = VBA.Replace(sResult, "Федеральное медико-биологическое агентство", "ФМБА")
+  sResult = VBA.Replace(sResult, "Федеральное архивное агентство", "Росархив")
+  sResult = VBA.Replace(sResult, "Федеральное космическое агентство", "Роскосмос")
+  sResult = VBA.Replace(sResult, "Федеральное дорожное агентство", "Росавтодор")
+  sResult = VBA.Replace(sResult, "Пенсионный фонд", "ПФ")
+  sResult = VBA.Replace(sResult, "Федеральный фонд обязательного медицинского страхования", "ФОМС")
+  sResult = VBA.Replace(sResult, "Фонд социального страхования", "ФСС")
+  
+  sResult = VBA.Replace(sResult, "Федеральной службы по техническому и экспортному контролю", "ФСТЭК")
+  sResult = VBA.Replace(sResult, "Федеральной службы безопасности", "ФСБ")
+  sResult = VBA.Replace(sResult, "Федеральной службы Российской Федерации по контролю за оборотом наркотиков", "ФСКН РФ")
+  sResult = VBA.Replace(sResult, "Федеральной службы охраны", "ФСО")
+  sResult = VBA.Replace(sResult, "Федеральной службы по гидрометеорологии и мониторингу окружающей среды", "Росгидромета")
+  sResult = VBA.Replace(sResult, "Федеральной службы по экологическому, технологическому и атомному надзору", "Ростехнадзора")
+  sResult = VBA.Replace(sResult, "Федеральной службы по надзору в сфере природопользования", "Росприроднадзора")
+  sResult = VBA.Replace(sResult, "Федеральной службы по ветеринарному и фитосанитарному надзору", "Россельхознадзора")
+  sResult = VBA.Replace(sResult, "Федеральной службы по надзору в сфере транспорта", "Ространснадзора")
+  sResult = VBA.Replace(sResult, "Федеральной службы по труду и занятости", "Роструда")
+  sResult = VBA.Replace(sResult, "Федеральной службы по регулированию алкогольного рынка", "Росалкогольрегулирования")
+  sResult = VBA.Replace(sResult, "Федеральной службы по надзору в сфере связи, информационных технологий и массовых коммуникаций", "Роскомнадзора")
+  sResult = VBA.Replace(sResult, "Федеральной службы по аккредитации", "Росаккредитации")
+  sResult = VBA.Replace(sResult, "Федеральной службы государственной статистики", "Росстата")
+  sResult = VBA.Replace(sResult, "Федеральной службы по интеллектуальной собственности", "Роспатента")
+  sResult = VBA.Replace(sResult, "Федеральной службы по финансовому мониторингу", "Росфинмониторинга")
+  sResult = VBA.Replace(sResult, "Федеральной службы государственной регистрации, кадастра и картографии", "Росреестра")
+  sResult = VBA.Replace(sResult, "Федеральной службы по надзору в сфере защиты прав потребителей и благополучия человека", "Роспотребнадзора")
+  sResult = VBA.Replace(sResult, "Федеральной службы по надзору в сфере здравоохранения", "Росздравнадзора")
+  sResult = VBA.Replace(sResult, "Федеральной службы по надзору в сфере образования и науки", "Рособзнадзора")
+  sResult = VBA.Replace(sResult, "Федеральной службы по экологическому, технологическому и атомному надзору", "Ростехнадзора")
+  sResult = VBA.Replace(sResult, "Федерального агентства по техническому регулированию и метрологии", "Росстандарта")
+  sResult = VBA.Replace(sResult, "Федерального агентства водных ресурсов", "Росводресурсов")
+  sResult = VBA.Replace(sResult, "Федерального агентства лесного хозяйства", "Рослесхоза")
+  sResult = VBA.Replace(sResult, "Федерального агентства по недропользованию", "Роснедр")
+  sResult = VBA.Replace(sResult, "Федерального агентства по рыболовству", "Росрыболовства")
+  sResult = VBA.Replace(sResult, "Федерального агентства воздушного транспорта", "Росавиации")
+  sResult = VBA.Replace(sResult, "Федерального агентства железнодорожного транспорта", "Росжелдора")
+  sResult = VBA.Replace(sResult, "Федерального агентства морского и речного транспорта", "Росморречфлота")
+  sResult = VBA.Replace(sResult, "Федерального агентства по управлению государственным имуществом", "Росимущества")
+  sResult = VBA.Replace(sResult, "Федерального агентства по печати и массовым коммуникациям", "Роспечати")
+  sResult = VBA.Replace(sResult, "Федерального агентства связи", "Россвязи")
+  sResult = VBA.Replace(sResult, "Федерального агентства по туризму", "Ростуризма")
+  sResult = VBA.Replace(sResult, "Федерального агентства по государственным резервам", "Росрезерва")
+  sResult = VBA.Replace(sResult, "Федерального агентства по делам молодёжи", "Росмолодёжи")
+  sResult = VBA.Replace(sResult, "Федерального агентства по делам национальностей", "ФАДН")
+  sResult = VBA.Replace(sResult, "Федеральной налоговой службы", "ФНС")
+  sResult = VBA.Replace(sResult, "Федеральной таможенной службы", "ФТС")
+  sResult = VBA.Replace(sResult, "Государственной фельдъегерской службы", "ГФС")
+  sResult = VBA.Replace(sResult, "Федеральной антимонопольной службы", "ФАС")
+  sResult = VBA.Replace(sResult, "Федерального медико-биологического агентства", "ФМБА")
+  sResult = VBA.Replace(sResult, "Федерального архивного агентства", "Росархива")
+  sResult = VBA.Replace(sResult, "Федерального космического агентства", "Роскосмоса")
+  sResult = VBA.Replace(sResult, "Федерального дорожного агентства", "Росавтодора")
+  sResult = VBA.Replace(sResult, "Пенсионного фонда", "ПФ")
+  sResult = VBA.Replace(sResult, "Федерального фонда обязательного медицинского страхования", "ФОМС")
+  sResult = VBA.Replace(sResult, "Фонда социального страхования", "ФСС")
+  
+  sResult = VBA.Replace(sResult, "Российская академия наук", "РАН")
+  sResult = VBA.Replace(sResult, "Российской академии наук", "РАН")
+
+  sResult = VBA.Replace(sResult, "Федеральная служба", "ФС")
+  sResult = VBA.Replace(sResult, "Федеральной службы", "ФС")
+  
+  sResult = VBA.Replace(sResult, "сельское хозяйство", "с/х")
+  sResult = VBA.Replace(sResult, "сельского хозяйства", "с/х")
+  sResult = VBA.Replace(sResult, "сельскому хозяйству", "с/х")
+  sResult = VBA.Replace(sResult, "сельском хозяйстве", "с/х")
+  
+  sResult = VBA.Replace(sResult, "железнодорожный", "ж/д")
+  sResult = VBA.Replace(sResult, "железнодорожного", "ж/д")
+  sResult = VBA.Replace(sResult, "железнодорожному", "ж/д")
+  sResult = VBA.Replace(sResult, "железнодорожном", "ж/д")
+  sResult = VBA.Replace(sResult, "железнодорожная", "ж/д")
+  sResult = VBA.Replace(sResult, "железнодорожной", "ж/д")
+  sResult = VBA.Replace(sResult, "железнодорожную", "ж/д")
+  sResult = VBA.Replace(sResult, "железнодорожное", "ж/д")
+  sResult = VBA.Replace(sResult, "железнодорожным", "ж/д")
+  
+  sResult = VBA.Replace(sResult, "  ", " ")
+  
+  ApplyCommonAbbreviations = sResult
+End Function
+
+Public Function SafeFileName(sText$) As String
+  Dim sResult$: sResult = sText
+  sResult = VBA.Replace(sResult, "*", "x")
+  sResult = VBA.Replace(sResult, "?", "7")
+  sResult = VBA.Replace(sResult, "/", "-")
+  sResult = VBA.Replace(sResult, "\", "-")
+  sResult = VBA.Replace(sResult, "|", "l")
+  sResult = VBA.Replace(sResult, ":", " ")
+  sResult = VBA.Replace(sResult, "<", "")
+  sResult = VBA.Replace(sResult, ">", "")
+  sResult = VBA.Replace(sResult, """", "'")
+  sResult = VBA.Replace(sResult, "' ", "'")
+  sResult = VBA.Replace(sResult, Chr(11), " ")
+  sResult = VBA.Replace(sResult, Chr(13), " ")
+  sResult = VBA.Replace(sResult, Chr(160), " ")
+  sResult = VBA.Replace(sResult, Chr(9), " ")
+  sResult = VBA.Replace(sResult, Chr(7), " ")
+  sResult = VBA.Replace(sResult, "  ", " ")
+  SafeFileName = sResult
+End Function
+
+Public Function QuotedStr(sText$) As String
+  QuotedStr = """" & sText & """"
+End Function
+
+Public Function TrimWhitespace(ByVal target$) As String
+  Dim sResult$: sResult = target
+  Dim bChanged As Boolean: bChanged = True
+  Do While bChanged
+    If VBA.Len(sResult) < 1 Then _
+      Exit Do
+    bChanged = False
+    
+    If IsWhitespace(VBA.Left(sResult, 1)) Then
+      sResult = VBA.Right(sResult, Len(sResult) - 1)
+      bChanged = True
+    End If
+    
+    If VBA.Len(sResult) < 1 Then _
+      Exit Do
+    If IsWhitespace(VBA.Right(sResult, 1)) Then
+      sResult = VBA.Left(sResult, VBA.Len(sResult) - 1)
+      bChanged = True
+    End If
+  Loop
+  
+  TrimWhitespace = sResult
+End Function
+
+Public Function TrimEndPunctuation(ByVal target$) As String
+  Dim sResult$: sResult = target
+  Dim isChanged As Boolean: isChanged = True
+  Do While isChanged
+    isChanged = False
+
+    If VBA.Len(sResult) < 1 Then _
+      GoTo END_LOOP
+    If IsPunctuation(VBA.Right(sResult, 1)) Then
+      sResult = VBA.Left(sResult, VBA.Len(sResult) - 1)
+      isChanged = True
+    End If
+    
+END_LOOP:
+  Loop
+  
+  TrimEndPunctuation = sResult
+End Function
+
+Public Function SubstituteWhitespace(ByVal target$) As String
+  SubstituteWhitespace = VBA.Replace(target, Chr(160), " ")
+  SubstituteWhitespace = VBA.Replace(SubstituteWhitespace, Chr(7), " ")
+  SubstituteWhitespace = VBA.Replace(SubstituteWhitespace, Chr(10), " ")
+  SubstituteWhitespace = VBA.Replace(SubstituteWhitespace, Chr(13), " ")
+  SubstituteWhitespace = VBA.Replace(SubstituteWhitespace, Chr(9), " ")
+  SubstituteWhitespace = VBA.Replace(SubstituteWhitespace, Chr(11), " ")
+  SubstituteWhitespace = VBA.Replace(SubstituteWhitespace, "  ", " ")
+  SubstituteWhitespace = Trim(SubstituteWhitespace)
+End Function
+
+Public Function FixSpecialSymbols(ByVal target$) As String
+  FixSpecialSymbols = VBA.Replace(target, Chr(160), " ")
+  FixSpecialSymbols = VBA.Replace(FixSpecialSymbols, Chr(7), " ")
+  FixSpecialSymbols = VBA.Replace(FixSpecialSymbols, Chr(10), " ")
+  FixSpecialSymbols = VBA.Replace(FixSpecialSymbols, Chr(13), " ")
+  FixSpecialSymbols = VBA.Replace(FixSpecialSymbols, Chr(9), " ")
+  FixSpecialSymbols = VBA.Replace(FixSpecialSymbols, Chr(11), " ")
+End Function
+
+Public Function CapitalizeFirstLetter(target$) As String
+  If VBA.Len(target) > 1 Then
+    CapitalizeFirstLetter = VBA.UCase(VBA.Left(target, 1)) & VBA.Right(target, VBA.Len(target) - 1)
+  Else
+    CapitalizeFirstLetter = target
+  End If
+End Function
+
+Public Function IsAlphaNumeric(sText$) As Boolean
+  IsAlphaNumeric = VBA.Len(sText) > 0 And Not sText Like "*[!a-zA-Zа-яА-ЯёЁ0-9]*"
+End Function
+
+' ================
+Private Function IsWhitespace(sSymbol$) As Boolean
+  IsWhitespace = True
+  If sSymbol = " " Then
+    Exit Function
+  ElseIf sSymbol = Chr(7) Then
+    Exit Function
+  ElseIf sSymbol = Chr(9) Then
+    Exit Function
+  ElseIf sSymbol = Chr(13) Then
+    Exit Function
+  ElseIf sSymbol = Chr(11) Then
+    Exit Function
+  ElseIf sSymbol = Chr(10) Then
+    Exit Function
+  ElseIf sSymbol = Chr(160) Then
+    Exit Function
+  End If
+  IsWhitespace = False
+End Function
+
+Private Function IsPunctuation(sSymbol$) As Boolean
+  IsPunctuation = True
+  If sSymbol = "." Then
+    Exit Function
+  ElseIf sSymbol = "," Then
+    Exit Function
+  ElseIf sSymbol = "-" Then _
+    Exit Function
+  ElseIf sSymbol = ChrW(&H2013) Then _
+    Exit Function
+  ElseIf sSymbol = ChrW(&H2012) Then _
+    Exit Function
+  ElseIf sSymbol = ChrW(&H2010) Then _
+    Exit Function
+  ElseIf sSymbol = ";" Then
+    Exit Function
+  ElseIf sSymbol = " " Then
+    Exit Function
+  ElseIf sSymbol = "!" Then
+    Exit Function
+  ElseIf sSymbol = ":" Then
+    Exit Function
+  ElseIf sSymbol = "?" Then
+    Exit Function
+  ElseIf sSymbol = """" Then
+    Exit Function
+  ElseIf sSymbol = "Chr(85)" Then
+    Exit Function
+  End If
+  IsPunctuation = False
+End Function

utility/ex_Hash.bas

@@ -0,0 +1,29 @@
+Attribute VB_Name = "ex_Hash"
+' ======== MD5 hash functions ========
+' Shared module version: 20210408
+' Tested in: TestCommons
+' Depends on:
+' Required reference:
+Option Private Module
+Option Explicit
+
+Public Function MD5AsLong(sText$) As Long
+  Dim sMD5$: sMD5 = MD5AsString(sText)
+  MD5AsLong = Abs(CLng("&H" & Right(sMD5, 8)))
+End Function
+
+Public Function MD5AsString(sText$) As String
+' Uses late binding for mscorlib 4.0 64-bit
+  If sText = vbNullString Then _
+    sText = ""
+  Dim oText As Object: Set oText = CreateObject("System.Text.UTF8Encoding")
+  Dim inBytes() As Byte: inBytes = oText.GetBytes_4(sText)
+  
+  Dim oMD5 As Object: Set oMD5 = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
+  Dim outBytes() As Byte: outBytes = oMD5.ComputeHash_2(inBytes)
+  
+  Dim nPos&
+  For nPos = 1 To VBA.LenB(outBytes) Step 1
+    MD5AsString = MD5AsString & LCase(Right("0" & VBA.Hex(VBA.AscB(VBA.MidB(outBytes, nPos, 1))), 2))
+  Next
+End Function

utility/ex_MSHook.bas

@@ -0,0 +1,74 @@
+Attribute VB_Name = "ex_MSHook"
+' =========== Microsoft event hooks ================
+' Shared module version: 20220703
+' Tested in:
+' Depends on:
+' Required reference:
+Option Explicit
+
+Private Declare PtrSafe Function FindWindow Lib "user32" _
+  Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
+Private Declare PtrSafe Function GetWindowLong Lib "user32" _
+  Alias "GetWindowLongA" (ByVal nHwnd As Long, ByVal nIndex As Long) As Long
+Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As Long
+
+Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" _
+  Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpFn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
+Private Declare PtrSafe Function CallNextHookEx Lib "user32" _
+                            (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As LongPtr
+Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
+
+Public Type LongPoint
+  x_ As Long
+  y_ As Long
+End Type
+
+Public Type MSLLHOOKSTRUCT
+  point_ As LongPoint
+  direction_ As Long
+  flags_ As Long
+  time_ As Long
+  info_ As Long
+End Type
+
+Public g_mouseHook As LongPtr
+Public g_hookData As MSLLHOOKSTRUCT
+Public g_hookCallback As Object
+Public g_hookCBFunction As String
+
+Private Const HC_ACTION = 0
+Private Const WH_MOUSE_LL = 14
+Private Const WM_MOUSEWHEEL = &H20A
+Private Const GWL_HINSTANCE = (-6)
+
+Private Const USERFORM_CLASSNAME = "ThunderDFrame"
+
+Public Function HookEnable(oCallback As Object, sCallbackFunc$)
+  If g_mouseHook > 0 Then _
+    Exit Function
+  Set g_hookCallback = oCallback
+  g_hookCBFunction = sCallbackFunc
+  g_mouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf HookProcess, _
+    GetWindowLong(FindWindow(USERFORM_CLASSNAME, g_hookCallback.Caption), GWL_HINSTANCE), 0)
+End Function
+
+Public Function HookDisable()
+  If g_mouseHook = 0 Then _
+    Exit Function
+  Call UnhookWindowsHookEx(g_mouseHook)
+  g_mouseHook = 0
+  Set g_hookCallback = Nothing
+End Function
+
+Public Function HookProcess(ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As MSLLHOOKSTRUCT) As LongPtr
+  If nCode <> HC_ACTION Or wParam <> WM_MOUSEWHEEL Then
+    HookProcess = CallNextHookEx(0, nCode, wParam, ByVal lParam)
+    Exit Function
+  End If
+  
+  If GetForegroundWindow <> FindWindow(USERFORM_CLASSNAME, g_hookCallback.Caption) Then _
+    Exit Function
+  
+  Call CallByName(g_hookCallback, g_hookCBFunction, VbMethod, lParam.direction_)
+  HookProcess = True
+End Function

utility/ex_Regex.bas

@@ -0,0 +1,108 @@
+Attribute VB_Name = "ex_Regex"
+' ======= General functions for String regex manipulations ========
+' Shared module version: 20210411
+' Tested in: TestCommons
+' Depends on:
+' Required reference: VBScript_RegExp_55
+
+' ====== API params =============
+' sTarget - string to execute the regex on
+' sPattern - the regular expression with at least 1 capture '()'
+' nMatch - the index of the match you want to return (default: 0)
+' nSubMatch - the index of the submatch you want to return (default: 0)
+
+' Regex Execute returns collection of Match
+' Match API: FirstIndex (0-indexed), Length, Value
+
+' More info: https://vremya-ne-zhdet.ru/vba-excel/regulyarnyye-vyrazheniya/
+
+Option Private Module
+Option Explicit
+
+Private Const REGEXP_SPECIAL$ = "[\?\.\$\^\(\)\[\]\{\}\\]"
+
+Public Function RegexCountMatches(sTarget$, sPattern$) As String
+'Returns the number of matches found for a given regex
+  Dim regEx As New VBScript_RegExp_55.RegExp
+  regEx.Pattern = sPattern
+  regEx.Global = True
+  Dim matches As Object
+  If regEx.Test(sTarget) Then
+    Set matches = regEx.Execute(sTarget)
+    RegexCountMatches = matches.Count
+    Exit Function
+  End If
+End Function
+
+Function RegexExecute(sTarget$, sPattern$, Optional bOnlyFirstMatch As Boolean = False) As Object
+'Executes a Regular Expression on a provided string and returns all matches
+  Dim regEx As New VBScript_RegExp_55.RegExp
+  regEx.Pattern = sPattern
+  regEx.Global = Not (bOnlyFirstMatch)
+  If regEx.Test(sTarget) Then
+    Set RegexExecute = regEx.Execute(sTarget)
+    Exit Function
+  End If
+End Function
+
+Public Function RegexExecuteGet(sTarget$, sPattern$, Optional nMatch& = 0, Optional nSubMatch& = 0) As String
+'Executes a Regular Expression on a provided string and returns a selected submatch
+  Dim regEx As New VBScript_RegExp_55.RegExp
+  regEx.Pattern = sPattern
+  regEx.Global = nMatch <> 0 Or nSubMatch <> 0
+  
+  If regEx.Test(sTarget) Then
+    Dim matches As Object:  Set matches = regEx.Execute(sTarget)
+    
+    On Error Resume Next
+    RegexExecuteGet = matches(nMatch).SubMatches(nSubMatch)
+  End If
+End Function
+
+Public Function RegexTest(sTarget$, sPattern$) As Boolean
+' Test if sTarget matches regExp
+  On Error GoTo EXIT_FUNC
+  
+  Dim regEx As New VBScript_RegExp_55.RegExp
+  regEx.Pattern = sTarget
+  regEx.Global = False
+  RegexTest = regEx.Test(sPattern)
+  
+  On Error GoTo 0
+EXIT_FUNC:
+End Function
+
+Public Function RegexMaskFrom(sTarget$) As String
+' Creating regex mask from string - using \ to shield regular symbols
+  RegexMaskFrom = RegexReplace(sTarget, "(" + REGEXP_SPECIAL + ")", "\$1")
+End Function
+
+Public Function RegexTextFromMask(mask$) As String
+' Remove shielding from symbols
+  RegexTextFromMask = RegexReplace(mask, "\\" + "(" + REGEXP_SPECIAL + ")", "$1")
+End Function
+
+Public Function RegexReplace(sTarget$, sPattern$, replaceStr$, Optional replaceLimit& = -1) As String
+Attribute RegexReplace.VB_Description = "Replace a pattern within a string with the provided replacement string based on all captures of the specified regular expression"
+Attribute RegexReplace.VB_ProcData.VB_Invoke_Func = " \n9"
+'Replaces a string using Regular Expressions
+'replaceStr - the string with which the sPattern pattern substrings are to be replaced with
+'replaceLimit - by default unlimited (-1). Providing value will limit the number of performed replacements
+  If replaceLimit = 0 Then
+    RegexReplace = sTarget
+    Exit Function
+  End If
+
+ Dim regEx As New VBScript_RegExp_55.RegExp
+ regEx.Pattern = sPattern
+ regEx.Global = IIf(replaceLimit = -1, True, False)
+  If replaceLimit <> -1 And replaceLimit <> 1 Then
+    RegexReplace = sTarget
+    Dim i&
+    For i = 1 To replaceLimit
+      RegexReplace = RegexReplace(RegexReplace, sPattern, replaceStr, 1)
+    Next i
+  Else
+    RegexReplace = regEx.Replace(sTarget, replaceStr)
+  End If
+End Function

utility/ex_Time.bas

@@ -0,0 +1,180 @@
+Attribute VB_Name = "ex_Time"
+' ======== Time conversion ========
+' Shared module version: 20210630
+' Tested in:
+' Depends on:
+' Required reference:
+Option Private Module
+Option Explicit
+
+''
+' VBA-UTC v1.0.6
+' (c) Tim Hall - https://github.com/VBA-tools/VBA-UtcConverter
+' UTC/ISO 8601 Converter for VBA
+' @license MIT (http://www.opensource.org/licenses/mit-license.php)
+'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
+
+Private Declare PtrSafe Function UTC_GetTimeZoneInfo Lib "kernel32" Alias "GetTimeZoneInformation" _
+    (utc_lpTimeZoneInformation As TTimeZone) As Long
+Private Declare PtrSafe Function UTC_SystemTimeToLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _
+    (utc_lpTimeZoneInformation As TTimeZone, utc_lpUniversalTime As TSystemTime, utc_lpLocalTime As TSystemTime) As Long
+Private Declare PtrSafe Function UTC_LocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _
+    (utc_lpTimeZoneInformation As TTimeZone, utc_lpLocalTime As TSystemTime, utc_lpUniversalTime As TSystemTime) As Long
+
+Private Type TSystemTime
+  utc_wYear As Integer
+  utc_wMonth As Integer
+  utc_wDayOfWeek As Integer
+  utc_wDay As Integer
+  utc_wHour As Integer
+  utc_wMinute As Integer
+  utc_wSecond As Integer
+  utc_wMilliseconds As Integer
+End Type
+
+Private Type TTimeZone
+  utc_Bias As Long
+  utc_StandardName(0 To 31) As Integer
+  utc_StandardDate As TSystemTime
+  utc_StandardBias As Long
+  utc_DaylightName(0 To 31) As Integer
+  utc_DaylightDate As TSystemTime
+  utc_DaylightBias As Long
+End Type
+
+Private Const ERR_UTC_PARSE_FAIL = vbObjectError + 1025
+Private Const ERR_UTC_CONVERSION_FAIL = vbObjectError + 1026
+Private Const ERR_ISO_PARSE_FAIL = vbObjectError + 1027
+Private Const ERR_ISO_CONVERSION_FAIL = vbObjectError + 1028
+
+' Parse UTC date to local date
+Public Function ParseUtc(utc_UtcDate As Date) As Date
+  On Error GoTo ON_ERROR
+
+  Dim utc_TimeZoneInfo As TTimeZone
+  Dim utc_LocalDate As TSystemTime
+
+  Call UTC_GetTimeZoneInfo(utc_TimeZoneInfo)
+  Call UTC_SystemTimeToLocalTime(utc_TimeZoneInfo, UTC_DateToSystemTime(utc_UtcDate), utc_LocalDate)
+
+  ParseUtc = UTC_SystemTimeToDate(utc_LocalDate)
+  Exit Function
+
+ON_ERROR:
+  Call Err.Raise(ERR_UTC_PARSE_FAIL, "UtcConverter.ParseUtc", "UTC parsing error: " & Err.Number & " - " & Err.Description)
+End Function
+
+' Convert local date to UTC date
+Public Function ConvertToUtc(utc_LocalDate As Date) As Date
+  On Error GoTo ON_ERROR
+
+  Dim utc_TimeZoneInfo As TTimeZone
+  Dim utc_UtcDate As TSystemTime
+
+  UTC_GetTimeZoneInfo utc_TimeZoneInfo
+  UTC_LocalTimeToSystemTime utc_TimeZoneInfo, UTC_DateToSystemTime(utc_LocalDate), utc_UtcDate
+
+  ConvertToUtc = UTC_SystemTimeToDate(utc_UtcDate)
+  Exit Function
+
+ON_ERROR:
+  Call Err.Raise(ERR_UTC_PARSE_FAIL, "UtcConverter.ConvertToUtc", "UTC conversion error: " & Err.Number & " - " & Err.Description)
+End Function
+
+' Parse ISO 8601 date string to local date
+Public Function ParseIso(sISOTime$) As Date
+  On Error GoTo ON_ERROR
+
+  Dim utc_Parts() As String
+  Dim utc_DateParts() As String
+  Dim utc_TimeParts() As String
+  Dim utc_OffsetIndex&
+  Dim utc_HasOffset As Boolean
+  Dim utc_NegativeOffset As Boolean
+  Dim utc_OffsetParts() As String
+  Dim utc_Offset As Date
+
+  utc_Parts = VBA.Split(sISOTime, "T")
+  utc_DateParts = VBA.Split(utc_Parts(0), "-")
+  ParseIso = VBA.DateSerial(VBA.CInt(utc_DateParts(0)), VBA.CInt(utc_DateParts(1)), VBA.CInt(utc_DateParts(2)))
+
+  If UBound(utc_Parts) > 0 Then
+    If VBA.InStr(utc_Parts(1), "Z") Then
+      utc_TimeParts = VBA.Split(VBA.Replace(utc_Parts(1), "Z", ""), ":")
+    Else
+      utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "+")
+      If utc_OffsetIndex = 0 Then
+        utc_NegativeOffset = True
+        utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "-")
+      End If
+
+      If utc_OffsetIndex > 0 Then
+        utc_HasOffset = True
+        utc_TimeParts = VBA.Split(VBA.Left$(utc_Parts(1), utc_OffsetIndex - 1), ":")
+        utc_OffsetParts = VBA.Split(VBA.Right$(utc_Parts(1), Len(utc_Parts(1)) - utc_OffsetIndex), ":")
+
+        Select Case UBound(utc_OffsetParts)
+        Case 0
+          utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), 0, 0)
+        Case 1
+          utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), 0)
+        Case 2
+          ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues
+          utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), Int(VBA.Val(utc_OffsetParts(2))))
+        End Select
+
+        If utc_NegativeOffset Then: utc_Offset = -utc_Offset
+      Else
+        utc_TimeParts = VBA.Split(utc_Parts(1), ":")
+      End If
+    End If
+
+    Select Case UBound(utc_TimeParts)
+    Case 0
+      ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), 0, 0)
+    Case 1
+      ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), 0)
+    Case 2
+      ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues
+      ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), Int(VBA.Val(utc_TimeParts(2))))
+    End Select
+
+    ParseIso = ParseUtc(ParseIso)
+
+    If utc_HasOffset Then
+      ParseIso = ParseIso - utc_Offset
+    End If
+  End If
+
+  Exit Function
+
+ON_ERROR:
+  Err.Raise ERR_ISO_PARSE_FAIL, "UtcConverter.ParseIso", "ISO 8601 parsing error for " & sISOTime & ": " & Err.Number & " - " & Err.Description
+End Function
+
+' Convert local date to ISO 8601 string
+Public Function ConvertToIso(utc_LocalDate As Date) As String
+  On Error GoTo ON_ERROR
+  ConvertToIso = VBA.Format$(ConvertToUtc(utc_LocalDate), "yyyy-mm-ddTHH:mm:ss.000Z")
+  Exit Function
+
+ON_ERROR:
+  Call Err.Raise(ERR_ISO_CONVERSION_FAIL, "UtcConverter.ConvertToIso", "ISO 8601 conversion error: " & Err.Number & " - " & Err.Description)
+End Function
+
+' =============================================
+Private Function UTC_DateToSystemTime(utc_Value As Date) As TSystemTime
+  UTC_DateToSystemTime.utc_wYear = VBA.Year(utc_Value)
+  UTC_DateToSystemTime.utc_wMonth = VBA.Month(utc_Value)
+  UTC_DateToSystemTime.utc_wDay = VBA.Day(utc_Value)
+  UTC_DateToSystemTime.utc_wHour = VBA.Hour(utc_Value)
+  UTC_DateToSystemTime.utc_wMinute = VBA.Minute(utc_Value)
+  UTC_DateToSystemTime.utc_wSecond = VBA.Second(utc_Value)
+  UTC_DateToSystemTime.utc_wMilliseconds = 0
+End Function
+
+Private Function UTC_SystemTimeToDate(utc_Value As TSystemTime) As Date
+  UTC_SystemTimeToDate = DateSerial(utc_Value.utc_wYear, utc_Value.utc_wMonth, utc_Value.utc_wDay) + _
+    TimeSerial(utc_Value.utc_wHour, utc_Value.utc_wMinute, utc_Value.utc_wSecond)
+End Function
+

utility/ex_VBA.bas

@@ -0,0 +1,469 @@
+Attribute VB_Name = "ex_VBA"
+' ======== VBA Extensions for objects and messaging ========
+' Shared module version: 20220623
+' Tested in: TestCommons
+' Depends on:
+' Required reference: Scripting
+Option Private Module
+Option Explicit
+
+Public Const VBA_INVALID_SIZE = -1
+
+Public Enum SystemErrors
+  SYS_ERR_TYPE_MISMATCH = 13
+  SYS_ERR_INVALID_OPERATION = 17
+End Enum
+
+Public Function ArraySize(target As Variant, Optional nDimension% = 1) As Long
+  On Error GoTo INVALID_SIZE
+  
+  ArraySize = UBound(target, nDimension) - LBound(target, nDimension) + 1
+  Exit Function
+
+INVALID_SIZE:
+  ArraySize = VBA_INVALID_SIZE
+End Function
+
+' Returns dictionary of indicies of first occurence for every element in array @aSource
+' Note: duplicate elements are ignored
+Public Function ArrayToIndex(iSource As Variant) As Scripting.Dictionary
+  If Not IsArrayAllocated(iSource) Then _
+    Exit Function
+    
+  Dim indicies As New Scripting.Dictionary
+  Dim vValue As Variant
+  Dim nIndex&: nIndex = LBound(iSource, 1)
+  For Each vValue In iSource
+    If Not indicies.Exists(vValue) Then _
+      Call indicies.Add(vValue, nIndex)
+    nIndex = nIndex + 1
+  Next vValue
+  Set ArrayToIndex = indicies
+End Function
+
+Public Function IsArrayAllocated(target As Variant) As Boolean
+  IsArrayAllocated = False
+  If Not IsArray(target) Then _
+    Exit Function
+    
+  On Error Resume Next
+  Dim nSize&: nSize = UBound(target, 1)
+  If Err.Number <> 0 Then
+    Call Err.Clear
+    Exit Function
+  End If
+  On Error GoTo 0
+  
+  IsArrayAllocated = LBound(target) <= UBound(target)
+End Function
+
+Public Function FixForwardedParams(params As Variant) As Variant
+  FixForwardedParams = params
+  If IsArrayAllocated(params) Then _
+    If VBA.IsArray(params(0)) Then _
+      If ArraySize(params, 1) = 1 Then _
+        FixForwardedParams = params(0)
+End Function
+
+Public Function CColl(ParamArray params() As Variant) As Collection
+  Set CColl = New Collection
+  Dim val As Variant
+  For Each val In params
+    Call CColl.Add(val)
+  Next val
+End Function
+
+Public Function CSet(ParamArray params() As Variant) As Scripting.Dictionary
+  Set CSet = New Scripting.Dictionary
+  Dim vValue As Variant
+  For Each vValue In params
+    CSet.Item(vValue) = 0
+  Next vValue
+End Function
+
+Public Function CDict(ParamArray params() As Variant) As Scripting.Dictionary
+  If UBound(params) > 0 Then _
+    If UBound(params) Mod 2 <> 1 Then _
+      Call Err.Raise(vbObjectError, Description:="Dictionary params should be key and value pairs")
+  
+  Set CDict = New Scripting.Dictionary
+  If UBound(params) <= 0 Then _
+    Exit Function
+  Dim nItem&
+  For nItem = 0 To UBound(params) / 2 Step 1
+    Call CDict.Add(params(2 * nItem), params(2 * nItem + 1))
+  Next nItem
+End Function
+
+Public Function CollectionToDictionary(iSource As Collection) As Scripting.Dictionary
+  Dim iDict As New Scripting.Dictionary
+  Dim nIndex&: nIndex = 1
+  Dim vValue As Variant
+  For Each vValue In iSource
+    If Not iDict.Exists(vValue) Then _
+      Call iDict.Add(vValue, nIndex)
+    nIndex = nIndex + 1
+  Next vValue
+  Set CollectionToDictionary = iDict
+End Function
+
+' Add unique (key, value) pairs from Source to Destination without deep copy
+Public Function DictionaryAbsorbShallow(iDestination As Scripting.Dictionary, iSource As Scripting.Dictionary)
+  Dim aKey As Variant
+  For Each aKey In iSource
+    If Not iDestination.Exists(aKey) Then _
+      Call iDestination.Add(aKey, iSource(aKey))
+  Next aKey
+End Function
+
+' Convert paramarray into unique list, where value equals 1-based index into input array
+' Duplicates are skipped
+Public Function UniqueList(ParamArray params() As Variant) As Scripting.Dictionary
+  Set UniqueList = New Scripting.Dictionary
+  Dim vValue As Variant
+  Dim nIndex&: nIndex = 1
+  For Each vValue In params
+    If Not UniqueList.Exists(vValue) Then _
+      Call UniqueList.Add(vValue, nIndex)
+    nIndex = nIndex + 1
+  Next vValue
+End Function
+
+' Compare two floats / integers and return difference or 0 if Precision is not met
+' Note: positive precision indicates number of positions after decimal
+'       while negative precision indicates positions before decimal
+Public Function CompareApproximate(val1 As Variant, val2 As Variant, nDecimalPrecision&) As Double
+  CompareApproximate = val1 - val2
+  If CompareApproximate = 0 Then _
+    Exit Function
+  If VBA.Log(VBA.Abs(CompareApproximate)) / VBA.Log(10) < -nDecimalPrecision Then _
+    CompareApproximate = 0
+End Function
+
+' Compate two Variants
+' Integer values will resolve into their difference
+' Other types will return 0 if objects are equal and unspecified number otherwise
+' Object type will try to call Compare() function if it is available for the type
+'   otherwise objects will by compared using ObjPtr()
+' If there is no way to compare values the Error SYS_ERR_INVALID_OPERATION will be raised
+' Warning: multidimensional arrays are not supported!
+Public Function CompareDeep(val1 As Variant, val2 As Variant) As Double
+  If TryMinus(val1, val2, CompareDeep) Then
+    Exit Function
+  ElseIf TryEquality(val1, val2) Then
+    CompareDeep = 0
+    Exit Function
+  ElseIf TryInequality(val1, val2) Then
+    CompareDeep = 1
+    Exit Function
+  End If
+  
+  Dim vType As VBA.VbVarType: vType = VBA.VarType(val1)
+  If vType <> VBA.VarType(val2) Then
+    GoTo UNCOMPARABLE
+  ElseIf vType >= vbArray And vType <= vbArray + vbByte Then
+    CompareDeep = CompareDeepArray(val1, val2)
+    Exit Function
+  End If
+  
+  Dim sType$: sType = VBA.TypeName(val1)
+  If sType <> VBA.TypeName(val2) Then _
+    GoTo UNCOMPARABLE
+  
+  On Error GoTo UNCOMPARABLE
+  Select Case sType
+    Case "Collection": CompareDeep = CompareDeepCollection(val1, val2)
+    Case "Dictionary": CompareDeep = CompareDeepDictionary(val1, val2)
+    Case Else: CompareDeep = CompareDeepObjects(val1, val2)
+  End Select
+  Exit Function
+  
+UNCOMPARABLE:
+  Call Err.Raise(SYS_ERR_INVALID_OPERATION)
+End Function
+
+Public Function ExtractTimestamp(sLine$) As Double
+  Dim sStamp$: sStamp = ExtractDatePrefix(sLine)
+  If sStamp = vbNullString Then _
+    Exit Function
+    
+  On Error GoTo INVALID_FORMAT
+  ExtractTimestamp = DateValue(sStamp) + TimeValue(sStamp)
+  Exit Function
+  
+INVALID_FORMAT:
+  Call Err.Clear
+  ExtractTimestamp = 0
+End Function
+
+Public Function TrimTimestamp(sLine$) As String
+  TrimTimestamp = sLine
+  Dim sStamp$: sStamp = ExtractDatePrefix(sLine)
+  If sStamp = vbNullString Then _
+    Exit Function
+  If ExtractTimestamp(sStamp) = 0 Then _
+    Exit Function
+  
+  If VBA.Len(sLine) > VBA.Len(sStamp) + 2 Then
+    TrimTimestamp = VBA.Right(sLine, VBA.Len(sLine) - VBA.Len(sStamp) - 2)
+  Else
+    TrimTimestamp = vbNullString
+  End If
+End Function
+
+Public Function CommonPrefixLength(sText1$, sText2$, Optional nMode As VbCompareMethod = vbBinaryCompare) As Long
+  Dim nPrefixEnd&: nPrefixEnd = 0
+  Dim nLen&: nLen = VBA.Len(sText1)
+  nLen = IIf(nLen < VBA.Len(sText2), VBA.Len(sText2), nLen)
+  Do While nPrefixEnd < nLen
+    If VBA.StrComp(VBA.Mid(sText1, nPrefixEnd + 1, 1), _
+                    VBA.Mid(sText2, nPrefixEnd + 1, 1), nMode) <> 0 Then _
+      Exit Do
+    nPrefixEnd = nPrefixEnd + 1
+  Loop
+  CommonPrefixLength = nPrefixEnd
+End Function
+
+' Formatting function
+' Expected message format: "test {1} argument enumerating 1-based"
+' Note: params array is 0-base enumerated
+Public Function Fmt(sMsg$, ParamArray params() As Variant) As String
+  Dim vValue As Variant
+  Dim nIndex&: nIndex = 1
+  Fmt = sMsg
+  
+  Dim unwrapped As Variant: unwrapped = params
+  unwrapped = FixForwardedParams(unwrapped)
+  For Each vValue In unwrapped
+    Fmt = VBA.Replace(Fmt, "{" & nIndex & "}", PrettyPrint(vValue))
+    nIndex = nIndex + 1
+  Next vValue
+End Function
+
+' Warning: multidimensional arrays are not supported!
+Public Function PrettyPrint(vValue As Variant, Optional nIndent& = 0) As String
+  Select Case VBA.VarType(vValue)
+    Case VBA.vbEmpty: PrettyPrint = "[Empty]"
+    Case VBA.vbNull: PrettyPrint = "[Null]"
+    Case VBA.vbString: PrettyPrint = vValue
+    Case VBA.vbArray To VBA.vbArray + VBA.vbByte: PrettyPrint = PrintArray(vValue, nIndent)
+    Case VBA.vbObject
+      If vValue Is Nothing Then
+        PrettyPrint = "[Nothing]"
+      ElseIf VBA.TypeName(vValue) = "Collection" Then
+        PrettyPrint = PrintCollection(vValue, nIndent)
+      ElseIf VBA.TypeName(vValue) = "Dictionary" Then
+        PrettyPrint = PrintDictionary(vValue, nIndent)
+      Else
+        PrettyPrint = PrintCustomObject(vValue, nIndent)
+      End If
+    Case Else: PrettyPrint = Var2Str(vValue)
+  End Select
+End Function
+
+Public Function Indent(Optional nIndent&)
+  Indent = VBA.String$(nIndent, "  ")
+End Function
+
+' ==========
+Private Function ExtractDatePrefix(sLine$) As String
+  If sLine = vbNullString Then _
+    Exit Function
+  Dim nEnd&: nEnd = VBA.InStr(1, sLine, " ")
+  If nEnd <> 0 Then _
+    nEnd = VBA.InStr(nEnd + 1, sLine, " ")
+  If nEnd = 0 Then
+    nEnd = VBA.Len(sLine)
+  Else
+    nEnd = nEnd - 1
+  End If
+  
+  If VBA.Mid(sLine, nEnd, 1) = ":" Then _
+    nEnd = nEnd - 1
+  ExtractDatePrefix = VBA.Left(sLine, nEnd)
+End Function
+
+Private Function Var2Str(target As Variant) As String
+  On Error GoTo CANNOT_CONVERT
+  Var2Str = CStr(target)
+  Exit Function
+  
+CANNOT_CONVERT:
+  Var2Str = "[T" & VarType(target) & "] "
+  On Error GoTo NON_STRING
+  If target Is Nothing Then
+    Var2Str = Var2Str & "Nothing"
+    Exit Function
+  End If
+
+NON_STRING:
+  Var2Str = Var2Str & "non-stringable"
+End Function
+
+Private Function TryEquality(val1 As Variant, val2 As Variant) As Boolean
+  On Error Resume Next
+  TryEquality = val1 = val2
+End Function
+
+Private Function TryInequality(val1 As Variant, val2 As Variant) As Boolean
+  On Error Resume Next
+  TryInequality = val1 <> val2
+End Function
+
+Private Function TryMinus(val1 As Variant, val2 As Variant, ByRef dDiff As Double) As Boolean
+  On Error GoTo CANNOT_DIFF
+  
+  dDiff = val1 - val2
+  TryMinus = True
+  Exit Function
+  
+CANNOT_DIFF:
+  TryMinus = False
+End Function
+
+Private Function CompareDeepArray(val1 As Variant, val2 As Variant) As Double
+  If Not IsArrayAllocated(val1) Then
+    CompareDeepArray = IIf(IsArrayAllocated(val2), 1, 0)
+    Exit Function
+  End If
+  
+  CompareDeepArray = UBound(val1) - UBound(val2)
+  If CompareDeepArray <> 0 Then _
+    Exit Function
+  CompareDeepArray = LBound(val1) - LBound(val2)
+  If CompareDeepArray <> 0 Then _
+    Exit Function
+  
+  On Error GoTo UNCOMPARABLE_ELEMENTS
+  Dim nItem&
+  For nItem = LBound(val1) To UBound(val2) Step 1
+    If CompareDeep(val1(nItem), val2(nItem)) <> 0 Then
+      CompareDeepArray = 1
+      Exit Function
+    End If
+  Next nItem
+  
+  CompareDeepArray = 0
+  Exit Function
+  
+UNCOMPARABLE_ELEMENTS:
+  CompareDeepArray = 1
+End Function
+
+Private Function CompareDeepCollection(val1 As Variant, val2 As Variant) As Double
+  Dim nCount&: nCount = val1.Count
+  CompareDeepCollection = nCount - val2.Count
+  If CompareDeepCollection <> 0 Then _
+    Exit Function
+    
+  On Error GoTo UNCOMPARABLE_ELEMENTS
+  Dim nItem&
+  For nItem = 1 To nCount Step 1
+    If CompareDeep(val1(nItem), val2(nItem)) <> 0 Then
+      CompareDeepCollection = 1
+      Exit Function
+    End If
+  Next nItem
+  
+  CompareDeepCollection = 0
+  Exit Function
+  
+UNCOMPARABLE_ELEMENTS:
+  CompareDeepCollection = 1
+End Function
+
+Private Function CompareDeepDictionary(val1 As Variant, val2 As Variant) As Double
+  Dim nCount&: nCount = val1.Count
+  CompareDeepDictionary = nCount - val2.Count
+  If CompareDeepDictionary <> 0 Then _
+    Exit Function
+    
+  On Error GoTo UNCOMPARABLE_ELEMENTS
+  Dim vKey As Variant
+  For Each vKey In val1
+    If Not val2.Exists(vKey) Then _
+      GoTo UNCOMPARABLE_ELEMENTS
+    If CompareDeep(val1(vKey), val2(vKey)) <> 0 Then
+      CompareDeepDictionary = 1
+      Exit Function
+    End If
+  Next vKey
+  
+  CompareDeepDictionary = 0
+  Exit Function
+  
+UNCOMPARABLE_ELEMENTS:
+  CompareDeepDictionary = 1
+End Function
+
+Public Function CompareDeepObjects(val1 As Variant, val2 As Variant) As Double
+  On Error Resume Next
+  CompareDeepObjects = val1.Compare(val2)
+  If Err.Number = 0 Then _
+    Exit Function
+  Call Err.Clear
+  CompareDeepObjects = IIf(ObjPtr(val1) = ObjPtr(val2), 0, 1)
+End Function
+
+Private Function PrintCollection(target As Variant, nIndent&) As String
+  If target.Count = 0 Then
+    PrintCollection = "$Collection []"
+    Exit Function
+  End If
+  
+  PrintCollection = "$Collection [" & vbNewLine
+  Dim nItem&: nItem = 0
+  Dim anItem As Variant
+  For Each anItem In target
+    nItem = nItem + 1
+    PrintCollection = PrintCollection & _
+      Indent(nIndent + 1) & PrettyPrint(anItem, nIndent + 1) & _
+      IIf(nItem <> target.Count, ",", "") & vbNewLine
+  Next anItem
+  PrintCollection = PrintCollection & Indent(nIndent) & "]"
+End Function
+
+Private Function PrintDictionary(target As Variant, nIndent&) As String
+  If target.Count = 0 Then
+    PrintDictionary = "$Dictionary []"
+    Exit Function
+  End If
+  
+  PrintDictionary = "$Dictionary [" & vbNewLine
+  Dim nItem&: nItem = 0
+  Dim aKey As Variant
+  For Each aKey In target
+    nItem = nItem + 1
+    PrintDictionary = PrintDictionary & _
+      Indent(nIndent + 1) & aKey & ": " & _
+      PrettyPrint(target(aKey), nIndent + 1) & _
+      IIf(nItem <> target.Count, ",", "") & vbNewLine
+  Next aKey
+  PrintDictionary = PrintDictionary & Indent(nIndent) & "]"
+End Function
+
+Private Function PrintCustomObject(vValue As Variant, nIndent&) As String
+  On Error GoTo PRINT_TYPE
+  PrintCustomObject = vValue.ToString(nIndent)
+  Exit Function
+PRINT_TYPE:
+  PrintCustomObject = "[" & VBA.TypeName(vValue) & "]"
+End Function
+
+Private Function PrintArray(target As Variant, nIndent&) As String
+  If Not IsArrayAllocated(target) Then
+    PrintArray = "$Array []"
+    Exit Function
+  End If
+  
+  PrintArray = "$Array [" & vbNewLine
+  Dim nItem&
+  Dim nLast&: nLast = UBound(target, 1)
+  For nItem = LBound(target, 1) To nLast
+    PrintArray = PrintArray & _
+      Indent(nIndent + 1) & PrettyPrint(target(nItem), nIndent + 1) & _
+      IIf(nItem <> nLast, ",", "") & vbNewLine
+  Next nItem
+  PrintArray = PrintArray & Indent(nIndent) & "]"
+End Function
+

utility/ex_Version.bas

@@ -0,0 +1,130 @@
+Attribute VB_Name = "ex_Version"
+' ======== Versioning helpers ========
+' Shared module version: 20221031
+' Tested in:
+' Depends on: API_DistrManifest
+' Required reference:
+Option Private Module
+Option Explicit
+
+Public Const CP_TOOLS_LOCAL = "C:\Tools"
+Public Const CP_UPDATE_SCRIPT = "UpdateConceptProducts"
+Public Const CP_VERSION_MSG_DELAY = 2000
+
+Public Const CP_TOOLS_SERVER = "\\fs1.concept.ru\Exchange\ConceptDistr"
+Public Const FILE_DISTRIBUTION_MANIFEST = "distribution_manifest.json"
+Public Const CONCEPT_INSTALLER = "install.bat"
+
+Public Const ADDIN_NAME_CONCEPT = "CONCEPT.dotm"
+Public Const ADDIN_NAME_NPA = "_Concept-NPA.dotm"
+Public Const ADDIN_NAME_MARKUP = "MARKUP.dotm"
+Public Const ADDIN_NAME_PARSER = "Parsers.dotm"
+Public Const ADDIN_NAME_MAKET = "_Maket.dotm"
+
+Public Function VersionValidate(sProduct$, sCurrentVersion$)
+  Dim iLocal As API_DistrManifest: Set iLocal = VersionLocalManifest
+  Dim sLocalVersion$: sLocalVersion = iLocal.GetVersion(sProduct)
+  If sLocalVersion = vbNullString Then
+    Debug.Print "Cannot access local manifest"
+    Exit Function
+  End If
+  
+  Dim iServer As API_DistrManifest: Set iServer = VersionServerManifest
+  Dim sServerVersion$: sServerVersion = iServer.GetVersion(sProduct)
+  
+  Dim bResult As Boolean: bResult = True
+  If VersionCompare(sLocalVersion, sCurrentVersion) > 0 Then _
+    bResult = False
+  If sServerVersion <> vbNullString Then _
+    If VersionCompare(sServerVersion, sCurrentVersion) > 0 Then _
+      bResult = False
+  
+  If bResult Then _
+    Exit Function
+  
+  If sServerVersion = vbNullString Then _
+    sServerVersion = "íå äîñòóïíà"
+  Dim sMsg$: sMsg = "Âíèìàíèå! Èñïîëüçóåìàÿ âåðñèÿ ïðîäóêòà óñòàðåëà!" & vbNewLine & _
+                    "Ñîçäàéòå ôàéë â íîâîé âåðñèè ïðîäóêòà" & vbNewLine & _
+                    "Ïðè íåîáõîäèìîñòè îáíîâèòå ïðîäóêò ñ ñåðâåðà" & vbNewLine & _
+                    "ID ïðîäóêòà: " & sProduct & vbNewLine & _
+                    "Âåðñèÿ ôàéëà: " & sCurrentVersion & vbNewLine & _
+                    "Âåðñèÿ ëîêàëüíàÿ: " & sLocalVersion & vbNewLine & _
+                    "Âåðñèÿ ñåðâåðíàÿ: " & sServerVersion
+  Call MsgBox(sMsg, vbOKOnly + vbExclamation, "Version control")
+End Function
+
+Public Function VersionCreateFile(sPath$, sVersion$) As Boolean
+  On Error GoTo RETURN_FALSE
+  Dim sFile$: sFile = sPath & "\" & "VERSION"
+  Dim nFileID&: nFileID = FreeFile
+  Open sFile For Output As nFileID
+  Print #nFileID, sVersion
+  Close #nFileID
+  
+  VersionCreateFile = True
+  Exit Function
+  
+RETURN_FALSE:
+  VersionCreateFile = False
+End Function
+
+Public Function VersionCompare(ver1$, ver2$) As Long
+  Dim vals1() As String: vals1 = VBA.Split(ver1, ".")
+  Dim vals2() As String: vals2 = VBA.Split(ver2, ".")
+  VersionCompare = CLng(vals1(0)) - CLng(vals2(0))
+  If VersionCompare <> 0 Then _
+    Exit Function
+  VersionCompare = CLng(vals1(1)) - CLng(vals2(1))
+  If VersionCompare <> 0 Then _
+    Exit Function
+  VersionCompare = CLng(vals1(2)) - CLng(vals2(2))
+End Function
+
+Public Function VersionLocalManifest() As API_DistrManifest
+  Static s_Manifest As API_DistrManifest
+  
+  If s_Manifest Is Nothing Then
+    Set s_Manifest = New API_DistrManifest
+    Call s_Manifest.LoadLocal
+  End If
+  
+  Set VersionLocalManifest = s_Manifest
+End Function
+
+Public Function VersionServerManifest() As API_DistrManifest
+  Static s_Manifest As API_DistrManifest
+  
+  If s_Manifest Is Nothing Then
+    Set s_Manifest = New API_DistrManifest
+    Call s_Manifest.LoadServer
+  End If
+  
+  Set VersionServerManifest = s_Manifest
+End Function
+
+Public Function VersionUpdateProducts(Optional sParams$ = "all")
+  VersionUpdateProducts = False
+  
+  Dim fso As New Scripting.FileSystemObject
+  Dim sScriptPath$: sScriptPath = CP_TOOLS_LOCAL & "\script\" & CP_UPDATE_SCRIPT & ".ps1"
+  If Not fso.FileExists(sScriptPath) Then _
+    Exit Function
+  
+  On Error GoTo RETURN_FALSE
+  Dim sExec$: sExec = "PowerShell -Command """ & _
+                        "." & " " & "'" & sScriptPath & "'" & ";" & _
+                        CP_UPDATE_SCRIPT & " " & "'" & CP_TOOLS_SERVER & "'" & " " & sParams & _
+                      """"
+  Dim iShell As Object: Set iShell = CreateObject("WScript.Shell")
+  VersionUpdateProducts = iShell.Run(sExec, waitOnReturn:=True) = 0
+  Exit Function
+
+RETURN_FALSE:
+  On Error GoTo 0
+End Function
+
+' =======
+Private Function LocalWordAddin(sName$) As String
+  LocalWordAddin = VBA.Environ$("APPDATA") & "\Microsoft\Word\STARTUP" & "\" & sName
+End Function

utility/z_QuickSort.bas

@@ -0,0 +1,30 @@
+Attribute VB_Name = "z_QuickSort"
+Option Explicit
+
+Public Function QuickSort(ByRef ids() As Variant, ByVal low&, ByVal high&, values As Collection)
+  Do While low < high
+    Dim pivot&: pivot = QPartition(ids, low, high, values)
+    Call QuickSort(ids, low, pivot - 1, values)
+    low = pivot + 1
+  Loop
+End Function
+
+Private Function QPartition(ByRef ids() As Variant, low&, high&, values As Collection) As Long
+  Dim pivot As Variant: pivot = ids(high)
+  Dim smallest&: smallest = low - 1
+  Dim n&
+  Dim tmp$
+  For n = low To high - 1
+    If values(CStr(ids(n))) < values(CStr(pivot)) Then
+      smallest = smallest + 1
+      tmp = ids(smallest)
+      ids(smallest) = ids(n)
+      ids(n) = tmp
+    End If
+  Next n
+  smallest = smallest + 1
+  tmp = ids(smallest)
+  ids(smallest) = ids(high)
+  ids(high) = tmp
+  QPartition = smallest
+End Function

visio/API_ShapeStorage.cls

@@ -0,0 +1,102 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_ShapeStorage"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ===== Visio shape storage manager simulating grid ========
+' Shared module version: 20210707
+' Depends on:
+' Required reference: Scripting
+Option Explicit
+
+Private Const SS_AREA_RATIO = 20#      ' target sum widht / height ratio
+Private Const SS_STORAGE_GAP = 0.1    ' gap between shapes in inches
+Private Const SS_STORAGE_MAX_LVL = 1024 ' maximum number of rows
+
+Private Const SS_PRECISION = 3
+
+Private originX_ As Double
+Private originY_ As Double
+
+Private areaHeight_ As Double
+
+Private lvlCount_ As Long
+
+Private levelHeight_(1 To SS_STORAGE_MAX_LVL) As Double
+Private levelX_(1 To SS_STORAGE_MAX_LVL) As Double
+Private levelY_(1 To SS_STORAGE_MAX_LVL) As Double
+
+Public items_ As Scripting.Dictionary
+
+Public Function Init(xOrigin As Double, yOrigin As Double)
+  originX_ = xOrigin
+  originY_ = yOrigin
+  areaHeight_ = 0
+  lvlCount_ = 0
+  
+  Set items_ = New Scripting.Dictionary
+End Function
+
+Public Property Get TargetPage() As Visio.Page
+  If items_.Count > 0 Then _
+    Set TargetPage = items_.Items(1).Parent
+End Property
+
+Public Function Store(target As Visio.Shape) As Boolean
+  Store = Not items_.Exists(target.ID)
+  If Not Store Then _
+    Exit Function
+  
+  Call items_.Add(target.ID, target)
+  
+  Dim nLvl&: nLvl = GetLevelForNew(target.Cells("Height"))
+  target.Cells("PinX") = levelX_(nLvl) + target.Cells("Width") / 2#
+  target.Cells("PinY") = levelY_(nLvl) + target.Cells("Height") / 2#
+  
+   Call IncrementLevelWidth(nLvl, target.Cells("Width"))
+End Function
+
+Public Function GiveBack(target As Visio.Shape)
+  If items_.Exists(target.ID) Then _
+    Call items_.Remove(target.ID)
+End Function
+
+'=============
+Private Function GetLevelForNew(dHeight As Double) As Long
+  Dim minLvl&: minLvl = 0
+  Dim minX As Double: minX = 100000000#
+  Dim nLvl&
+  For nLvl = 1 To lvlCount_ Step 1
+    If VBA.Round(levelHeight_(nLvl), SS_PRECISION) + SS_STORAGE_GAP >= VBA.Round(dHeight, SS_PRECISION) And _
+        VBA.Round(minX, SS_PRECISION) > VBA.Round(levelX_(nLvl), SS_PRECISION) Then
+      minLvl = nLvl
+      minX = levelX_(nLvl)
+    End If
+  Next nLvl
+  
+  If minLvl = 0 Then
+    GetLevelForNew = CreateNewLevel(dHeight)
+  ElseIf levelX_(minLvl) > SS_AREA_RATIO * VBA.Round(areaHeight_, SS_PRECISION) And lvlCount_ <= SS_STORAGE_MAX_LVL Then
+    GetLevelForNew = CreateNewLevel(dHeight)
+  Else
+    GetLevelForNew = minLvl
+  End If
+End Function
+
+Private Function CreateNewLevel(dHeight As Double) As Long
+  lvlCount_ = lvlCount_ + 1
+  levelHeight_(lvlCount_) = dHeight
+  levelY_(lvlCount_) = originY_ + areaHeight_
+  levelX_(lvlCount_) = originX_
+  areaHeight_ = areaHeight_ + dHeight + SS_STORAGE_GAP
+  
+  CreateNewLevel = lvlCount_
+End Function
+
+Private Function IncrementLevelWidth(nLvl&, incWidth As Double)
+  levelX_(nLvl) = levelX_(nLvl) + SS_STORAGE_GAP + incWidth
+End Function

visio/API_UndoWrapper.cls

@@ -0,0 +1,45 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_UndoWrapper"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ====== Class for managing Visio undo scopes ==========
+' Shared module version: 20210329
+' Tested in: TestVisio
+' Depends on:
+' Required reference:
+Option Explicit
+
+Private app_ As Visio.Application
+Private scopeID_ As Long
+Private isActive_ As Boolean
+
+Private Sub Class_Initialize()
+  scopeID_ = 0
+  isActive_ = False
+End Sub
+
+Public Function Init(targetApp As Visio.Application)
+  Set app_ = targetApp
+End Function
+
+Public Function BeginScope(sName$)
+  If isActive_ Then
+    Debug.Print "Scope already running"
+    Exit Function
+  Else
+    isActive_ = True
+    scopeID_ = app_.BeginUndoScope(sName)
+  End If
+End Function
+
+Public Function EndScope(Optional bCommit As Boolean = True)
+  If isActive_ Then
+    isActive_ = False
+    Call app_.EndUndoScope(scopeID_, bCommit)
+  End If
+End Function

visio/z_CCVsoExtension.bas

@@ -0,0 +1,432 @@
+Attribute VB_Name = "z_CCVsoExtension"
+' ============== Module for additional functionality for CIHT CONCEPT ====================
+' Shared module version: 20220714
+' Tested in: TestVisio
+' Depends on: CDS_Factorizator, z_VsoUtilities, CDS_Graph, API_VsoWrapper, z_VsoGraph
+' Required reference: Scripting
+Option Explicit
+
+Private Const CC_DEFAULT_CONNECTOR_NAME = "Ñîåäèíèòåëü"
+
+Public Sub CC_DispatchCommand(sCommand$)
+  Select Case sCommand
+    Case "WidthAdd10":        Call CC_WidthAdd10
+    Case "WidthSub10":        Call CC_WidthSub10
+    Case "TopAlignment":      Call CC_TopAlignment
+    Case "LeftAlignment":     Call CC_LeftAlignment
+    Case "ExpandStraight":    Call CC_ExpandStraight
+    Case "ExpandReverse":     Call CC_ExpandReverse
+    Case "GotoLinkBegin":     Call CC_GotoLinkBegin
+    Case "GotoLinkEnd":       Call CC_GotoLinkEnd
+    Case "IterateSimilar":    Call CC_IterateSimilar
+    Case "RedirectConnects":  Call CC_RedirectConnectors
+    Case "CreateConnects":    Call CC_CreateConnectors
+    Case "Convert1251":       Call CC_Convert1251
+  End Select
+End Sub
+
+Public Sub CC_SelectByID()
+  Dim target As Visio.Shape
+  Dim sName$: sName = VBA.InputBox("Input ID")
+  If sName = vbNullString Then _
+    Exit Sub
+  
+  If Not IsNumeric(sName) Then
+    Call MsgBox("Invalid ID", vbExclamation)
+    Exit Sub
+  End If
+  
+  On Error Resume Next
+  Set target = Visio.Application.ActivePage.Shapes.ItemFromID(CLng(sName))
+  On Error GoTo 0
+  
+  If target Is Nothing Then
+    Call MsgBox("Invalid ID", vbExclamation)
+    Exit Sub
+  End If
+  
+  Dim iSelection As Visio.Selection: Set iSelection = Visio.Application.ActiveWindow.Selection
+  Call iSelection.DeselectAll
+  Call iSelection.Select(target, visSelect)
+  Visio.Application.ActiveWindow.Selection = iSelection
+  Call Visio.Application.ActiveWindow.CenterViewOnShape(target, visCenterViewSelectShape)
+End Sub
+
+Public Sub CC_GotoLinkBegin()
+  Dim iConnector As Visio.Shape: Set iConnector = GetSelectedConnector
+  If iConnector Is Nothing Then _
+    Exit Sub
+  Dim iTarget As Visio.Shape: Set iTarget = VsoGetConnectedShape(iConnector, bBegin:=True)
+  Call VsoCenterViewOn(iTarget)
+End Sub
+
+Public Sub CC_GotoLinkEnd()
+  Dim iConnector As Visio.Shape: Set iConnector = GetSelectedConnector
+  If iConnector Is Nothing Then _
+    Exit Sub
+  Dim iTarget As Visio.Shape: Set iTarget = VsoGetConnectedShape(iConnector, bBegin:=False)
+  Call VsoCenterViewOn(iTarget)
+End Sub
+
+Public Sub CC_WidthAdd10()
+  If ActiveWindow.Selection.Count = 0 Then
+    Call MsgBox("Âûäåëèòå ôèãóðó", vbExclamation)
+    Exit Sub
+  End If
+  Call GlobalUndo.BeginScope("Óâåëè÷åíèå øèðèíû")
+  ThisDocument.DiagramServicesEnabled = visServiceStructureBasic
+  
+  Call VsoIncrementWidth(ActiveWindow.Selection(1), 10)
+  
+  ThisDocument.DiagramServicesEnabled = 0
+  Call GlobalUndo.EndScope
+End Sub
+
+Public Sub CC_WidthSub10()
+  If ActiveWindow.Selection.Count = 0 Then
+    Call MsgBox("Âûäåëèòå ôèãóðó", vbExclamation)
+    Exit Sub
+  End If
+  Call GlobalUndo.BeginScope("Óìåíüøåíèå øèðèíû")
+  ThisDocument.DiagramServicesEnabled = visServiceStructureBasic
+  
+  Call VsoIncrementWidth(ActiveWindow.Selection(1), -10)
+  
+  ThisDocument.DiagramServicesEnabled = 0
+  Call GlobalUndo.EndScope
+End Sub
+
+Public Sub CC_IterateSimilar()
+Attribute CC_IterateSimilar.VB_ProcData.VB_Invoke_Func = "F"
+  Dim iSelected As Visio.Selection: Set iSelected = Visio.Application.ActiveWindow.Selection
+  Dim iShape As Visio.Shape
+  Dim nItem&: nItem = 1
+  Do
+    If nItem > iSelected.Count Then _
+      Exit Do
+    Set iShape = iSelected.Item(nItem)
+    If iShape.OneD Then
+      Call iSelected.Select(iShape, visDeselect)
+    Else
+      nItem = nItem + 1
+    End If
+  Loop
+  
+  If iSelected.Count = 0 Then
+    Call MsgBox("Select at least one shape", vbExclamation)
+    Exit Sub
+  End If
+  
+  Dim iTarget As Visio.Shape: Set iTarget = iSelected.Item(1)
+  
+  Dim idList As Scripting.Dictionary: Set idList = ExtractShapeIDs(iTarget)
+  If idList Is Nothing Then
+    Call MsgBox("Selected shape is missing IDs", vbExclamation)
+    Exit Sub
+  End If
+  
+  Dim filteredIDs As Collection: Set filteredIDs = FilterPageIDs(Visio.Application.ActivePage, idList)
+  
+  Call iSelected.DeselectAll
+  Dim nStart&: nStart = -1
+  For nItem = 1 To filteredIDs.Count Step 1
+    Set iShape = filteredIDs.Item(nItem)
+    If nStart <> -1 Then _
+      Call iSelected.Select(iShape, visSelect)
+    If iShape.ID = iTarget.ID Then
+      nStart = nItem
+      If nStart = filteredIDs.Count Then _
+        nStart = 1
+    End If
+  Next nItem
+  
+  For nItem = 1 To nStart Step 1
+    Call iSelected.Select(filteredIDs.Item(nItem), visSelect)
+  Next nItem
+  
+  Visio.Application.ActiveWindow.Selection = iSelected
+  Call Visio.Application.ActiveWindow.CenterViewOnShape(iSelected.Item(1), visCenterViewSelectShape)
+End Sub
+
+' Create connections from all selected to last selected
+Public Sub CC_CreateConnectors()
+  Dim iSelected As Visio.Selection: Set iSelected = ThisDocument.Application.ActiveWindow.Selection
+  If iSelected.Count < 2 Then
+    Call MsgBox("Select at least two shapes", vbExclamation)
+    Exit Sub
+  End If
+  
+  Call GlobalUndo.BeginScope("Ñîçäàòü ñâÿçè")
+  
+  Dim shapeTo As Visio.Shape: Set shapeTo = iSelected(iSelected.Count)
+  Dim shapeFrom As Visio.Shape
+  Dim conShp As Visio.Shape
+  Dim iMaster As Visio.Master: Set iMaster = FindMaster(ThisDocument, CC_DEFAULT_CONNECTOR_NAME)
+  Dim nItem&
+  For nItem = 1 To iSelected.Count - 1 Step 1
+    Set shapeFrom = iSelected(nItem)
+    If shapeFrom.Connects.Count <> 0 Then _
+      GoTo NEXT_ITEM
+    If iMaster Is Nothing Then
+      Call shapeFrom.AutoConnect(shapeTo, visAutoConnectDirNone)
+    Else
+      Call shapeFrom.AutoConnect(shapeTo, visAutoConnectDirNone, iMaster)
+    End If
+NEXT_ITEM:
+  Next nItem
+  
+  Call GlobalUndo.EndScope
+End Sub
+
+' Move connectors end to last selected
+Public Sub CC_RedirectConnectors()
+  Dim iSelected As Visio.Selection: Set iSelected = ThisDocument.Application.ActiveWindow.Selection
+  If iSelected.Count < 2 Then
+    Call MsgBox("Select at least one connector and one shape", vbExclamation)
+    Exit Sub
+  End If
+  
+  Dim shapeTo As Visio.Shape: Set shapeTo = iSelected(iSelected.Count)
+  If shapeTo.Connects.Count <> 0 Then
+    Call MsgBox("Select valid shape last (not connector!)", vbExclamation)
+    Exit Sub
+  End If
+  
+  Call GlobalUndo.BeginScope("Ïåðåíåñòè êîíöû")
+  
+  Dim nItem&
+  For nItem = 1 To iSelected.Count - 1 Step 1
+    Call iSelected(nItem).CellsU("EndX").GlueTo(shapeTo.CellsU("PinX"))
+  Next nItem
+  
+  Call GlobalUndo.EndScope
+End Sub
+
+Public Sub CC_TopAlignment()
+  Dim dGap As Double: dGap = PromptAlignGap
+  If dGap = 0 Then _
+    Exit Sub
+  Dim iShapes As Collection: Set iShapes = VsoActiveShapes(ThisDocument.Application)
+  If iShapes.Count = 0 Then _
+    Exit Sub
+
+  Dim vsoUI As New API_VsoWrapper: Call vsoUI.SetDocument(ThisDocument)
+  Call vsoUI.PauseUI
+  ThisDocument.DiagramServicesEnabled = visServiceStructureBasic
+  Call GlobalUndo.BeginScope("Âûðàâíèâàíèå")
+  
+  Call VsoAlignShapes(iShapes, dGap, bAlignTop:=True)
+  
+  Call GlobalUndo.EndScope
+  ThisDocument.DiagramServicesEnabled = 0
+  Call vsoUI.ResumeUI
+End Sub
+
+Public Sub CC_LeftAlignment()
+  Dim dGap As Double: dGap = PromptAlignGap
+  If dGap = 0 Then _
+    Exit Sub
+  Dim iShapes As Collection: Set iShapes = VsoActiveShapes(ThisDocument.Application)
+  If iShapes.Count = 0 Then _
+    Exit Sub
+
+  Dim vsoUI As New API_VsoWrapper: Call vsoUI.SetDocument(ThisDocument)
+  Call vsoUI.PauseUI
+  ThisDocument.DiagramServicesEnabled = visServiceStructureBasic
+  Call GlobalUndo.BeginScope("Âûðàâíèâàíèå")
+  
+  Call VsoAlignShapes(iShapes, dGap, bAlignTop:=False)
+  
+  Call GlobalUndo.EndScope
+  ThisDocument.DiagramServicesEnabled = 0
+  Call vsoUI.ResumeUI
+End Sub
+
+Public Sub CC_ExpandReverse()
+  If ThisDocument.Application.ActiveWindow.Selection.Count = 0 Then
+    Call MsgBox("Âûäåëèòå Ýëåìåíò", vbExclamation)
+    Exit Sub
+  End If
+  
+  Dim iSelected As Collection: Set iSelected = VsoActiveShapes(ThisDocument.Application)
+  Dim iGraph As CDS_Graph: Set iGraph = ScanGraph(iSelected, bReverseLinks:=True)
+  Call VsoSelectShapesIDs(iGraph.Nodes, ThisDocument.Application.ActivePage)
+End Sub
+
+Public Sub CC_ExpandStraight()
+  If ThisDocument.Application.ActiveWindow.Selection.Count = 0 Then
+    Call MsgBox("Âûäåëèòå Ýëåìåíò", vbExclamation)
+    Exit Sub
+  End If
+  
+  Dim iSelected As Collection: Set iSelected = VsoActiveShapes(ThisDocument.Application)
+  Dim iGraph As CDS_Graph: Set iGraph = ScanGraph(iSelected, bReverseLinks:=False)
+  Call VsoSelectShapesIDs(iGraph.Nodes, ThisDocument.Application.ActivePage)
+End Sub
+
+Public Sub CC_Convert1251()
+  Dim iShapes As Collection: Set iShapes = VsoActiveShapes(ThisDocument.Application)
+  If iShapes.Count = 0 Then _
+    Exit Sub
+    
+  Dim aShape As Visio.Shape
+  For Each aShape In iShapes
+    Dim sText$: sText = aShape.Text
+    Dim sNewText$: sNewText = Convert1251(aShape.Text)
+    If sText <> sNewText Then _
+      aShape.Text = sNewText
+  Next aShape
+End Sub
+
+Public Function VsoAlignShapes(target As Collection, dGap As Double, bAlignTop As Boolean)
+  Dim iFactors As New CDS_Factorizator
+  Call iFactors.Init(Application.ConvertResult(dGap, "mm", "in"))
+  
+  Dim sCellPosition$: sCellPosition = IIf(bAlignTop, "PinY", "PinX")
+  Dim sDimension$: sDimension = IIf(bAlignTop, "Height", "Width")
+  Dim k&: k = IIf(bAlignTop, 1, -1)
+  
+  Dim aShape As Visio.Shape
+  For Each aShape In target
+    If VsoIsMovable(aShape) Then _
+      Call iFactors.Insert(aShape.ID, k * (aShape.CellsU(sCellPosition) + k * aShape.CellsU(sDimension) / 2#))
+  Next aShape
+  
+  For Each aShape In target
+    Dim vFactor As Variant: vFactor = iFactors.FactorFor(aShape.ID)
+    If vFactor = Empty Then _
+      GoTo NEXT_SHAPE
+    If vFactor = aShape.ID Then _
+      GoTo NEXT_SHAPE
+      
+    Dim targetPos As Double: targetPos = iFactors.FactorValueFor(vFactor)
+    aShape.CellsU(sCellPosition) = k * (targetPos - aShape.CellsU(sDimension) / 2#)
+NEXT_SHAPE:
+  Next aShape
+End Function
+
+Public Function ExtractShapeIDs(target As Visio.Shape) As Scripting.Dictionary
+  Dim sText$: sText = target.Text
+  If sText = vbNullString And target.Shapes.Count > 1 Then _
+    sText = target.Shapes(1).Text
+  If sText = vbNullString Then _
+    Exit Function
+  
+  Dim sPrefix$: sPrefix = ExtractShapePrefix(sText)
+  If sPrefix = vbNullString Then
+    Set ExtractShapeIDs = New Scripting.Dictionary
+    Call ExtractShapeIDs.Add(VBA.Trim(sText), VBA.Trim(sText))
+    Exit Function
+  End If
+  
+  Set ExtractShapeIDs = SplitPrefix(sPrefix)
+End Function
+
+Public Function FilterPageIDs(iPage As Visio.Page, iFilter As Scripting.Dictionary) As Collection
+  Dim iResult As New Collection
+  Dim idList As Scripting.Dictionary
+  Dim iShape As Visio.Shape
+  For Each iShape In iPage.Shapes
+    Set idList = ExtractShapeIDs(iShape)
+    If Not idList Is Nothing Then
+      Dim iKey As Variant
+      For Each iKey In idList.Keys
+        Dim sValue$: sValue = idList(iKey)
+        If iFilter.Exists(sValue) Then
+          Call iResult.Add(iShape)
+          Exit For
+        End If
+      Next iKey
+    End If
+  Next iShape
+  Set FilterPageIDs = iResult
+End Function
+
+' ========
+Private Function GetSelectedConnector() As Visio.Shape
+  Dim iSelected As Visio.Selection: Set iSelected = Application.ActiveWindow.Selection
+  If iSelected.Count <> 1 Then
+    Call MsgBox("Âûáåðèòå ñîåäèíèòåëü", vbExclamation)
+    Exit Function
+  End If
+  Dim iConnector As Visio.Shape: Set iConnector = iSelected(1)
+  If iConnector.Connects.Count = 0 Then
+    Call MsgBox("Âûáðàííûé ñîåäèíèòåëü äîëæåí áûòü ïðèêðåëïåí ê ôèãóðàì", vbExclamation)
+    Exit Function
+  End If
+  Set GetSelectedConnector = iConnector
+End Function
+
+Private Function PromptAlignGap() As Double
+  Dim sInput$: sInput = InputBox("Ââåäèòå ïîðîãîâîå ðàçëè÷èå â ìèëëèìåòðàõ", Default:="10")
+  If sInput = vbNullString Then _
+    Exit Function
+  If Not IsNumeric(sInput) Then
+    Call MsgBox("Ââåäèòå ÷èñëî", vbExclamation)
+    Exit Function
+  End If
+  PromptAlignGap = CDbl(sInput)
+End Function
+
+Private Function Convert1251(sText$) As String
+  If sText = "" Then _
+    Exit Function
+  
+  Dim nChr&
+  For nChr = 1 To VBA.Len(sText)
+    Dim aChr$: aChr = VBA.Mid$(sText, nChr, 1)
+    Dim uniChr&: uniChr = VBA.AscW(aChr)
+    If uniChr < 256 And uniChr > 127 Then _
+      aChr = VBA.Chr(uniChr)
+    Convert1251 = Convert1251 & aChr
+  Next nChr
+End Function
+
+Private Function ExtractShapePrefix(sText$) As String
+  Dim nChr&
+  For nChr = 1 To VBA.Len(sText) Step 1
+    If VBA.Mid$(sText, nChr, 1) Like "[à-ÿ¸a-zA-Z]" Then
+      nChr = nChr - 1
+      Exit For
+    End If
+  Next nChr
+  If nChr = 0 Then _
+    Exit Function
+  
+  Dim sResult$: sResult = VBA.Left(sText, nChr)
+  If VBA.InStr(1, sResult, " ", vbTextCompare) = 0 Then _
+    Exit Function
+  
+  ExtractShapePrefix = VBA.Trim(VBA.Left(sResult, VBA.InStrRev(sResult, " ")))
+End Function
+
+Private Function SplitPrefix(sPrefix$) As Scripting.Dictionary
+  Dim iResult As New Scripting.Dictionary
+  If VBA.InStr(1, sPrefix, "(") = 0 Then
+    Call iResult.Add(sPrefix, sPrefix)
+    Set SplitPrefix = iResult
+    Exit Function
+  End If
+  
+  Dim nStart&: nStart = -1
+  Dim nChr&
+  For nChr = 1 To VBA.Len(sPrefix) Step 1
+    Dim aChr$: aChr = VBA.Mid$(sPrefix, nChr, 1)
+    If aChr = "(" Then
+      nStart = nChr
+    ElseIf aChr = ")" Then
+      If nStart <> -1 And nStart + 1 < nChr Then
+        Dim sID$: sID = VBA.Trim(VBA.Mid$(sPrefix, nStart + 1, nChr - nStart - 1))
+        If sID <> vbNullString Then
+          On Error Resume Next
+          Call iResult.Add(sID, sID)
+          On Error GoTo 0
+        End If
+        nStart = -1
+      End If
+    End If
+  Next nChr
+  If iResult.Count = 0 Then _
+    Call iResult.Add(sPrefix, sPrefix)
+  Set SplitPrefix = iResult
+End Function

visio/z_VsoGraph.bas

@@ -0,0 +1,132 @@
+Attribute VB_Name = "z_VsoGraph"
+' ========= Extension functions for Visio ========
+' Shared module version: 20210414
+' Depends on: CDS_Graph
+' Required reference: Scripting
+Option Private Module
+Option Explicit
+
+Public Enum TConnectorDirection
+  T_CD_NONE = 0
+  T_CD_STRAIGHT = 1
+  T_CD_REVERSE = 2
+  T_CD_MUTUAL = 3
+End Enum
+
+Public Type ItemConnector
+  begin_ As Visio.Shape
+  end_ As Visio.Shape
+  dir_ As TConnectorDirection
+End Type
+
+Public Function ScanConnector(iArrow As Visio.Shape) As ItemConnector
+  ScanConnector.dir_ = GetConnectorDirection(iArrow)
+  If iArrow.Connects.Count = 2 Then
+    Set ScanConnector.begin_ = iArrow.Connects(1).ToSheet
+    Set ScanConnector.end_ = iArrow.Connects(2).ToSheet
+  ElseIf iArrow.Connects.Count = 1 Then
+    If iArrow.CellsU("BeginX").Formula Like "*GLUE*" Then
+      Set ScanConnector.begin_ = iArrow.Connects(1).ToSheet
+    Else
+      Set ScanConnector.end_ = iArrow.Connects(1).ToSheet
+    End If
+  End If
+End Function
+
+Public Function ScanGraph(ByRef iSeed As Collection, bReverseLinks As Boolean) As CDS_Graph
+  Dim iVisited As New Scripting.Dictionary
+  Dim iGraph As New CDS_Graph
+  Do While iSeed.Count > 0
+    Dim aShape As Visio.Shape: Set aShape = iSeed.Item(1)
+    Call iSeed.Remove(1)
+    If aShape.OneD Then _
+      GoTo NEXT_SHAPE
+      
+    Dim nShape&: nShape = aShape.ID
+    If iVisited.Exists(nShape) Then _
+      GoTo NEXT_SHAPE
+      
+    Call iVisited.Add(nShape, 0)
+    Call iGraph.AddNode(nShape)
+    Call ScanConnectorsFor(aShape, iSeed, iGraph, bReverseLinks)
+    
+NEXT_SHAPE:
+  Loop
+  Set ScanGraph = iGraph
+End Function
+
+Public Function VsoGetConnectedShape(vConnector As Visio.Shape, bBegin As Boolean) As Visio.Shape
+  Dim iConnector As ItemConnector: iConnector = ScanConnector(vConnector)
+  If bBegin Then
+    Set VsoGetConnectedShape = IIf(iConnector.dir_ <> T_CD_REVERSE, iConnector.begin_, iConnector.end_)
+  Else
+    Set VsoGetConnectedShape = IIf(iConnector.dir_ <> T_CD_REVERSE, iConnector.end_, iConnector.begin_)
+  End If
+End Function
+
+' =====
+Private Function IsArrow(nEndType&) As Boolean
+  Select Case nEndType
+    Case 1 To 8: IsArrow = True
+    Case 12 To 19: IsArrow = True
+    Case 39 To 40: IsArrow = True
+    Case 43 To 45: IsArrow = True
+    Case Else: IsArrow = False
+  End Select
+End Function
+
+Private Function GetConnectorDirection(target As Visio.Shape) As TConnectorDirection
+  Dim bBegin As Boolean: bBegin = IsArrow(target.CellsU("BeginArrow"))
+  Dim bFinish As Boolean: bFinish = IsArrow(target.CellsU("EndArrow"))
+  
+  If bBegin Then
+    GetConnectorDirection = IIf(bFinish, T_CD_MUTUAL, T_CD_REVERSE)
+  Else
+    GetConnectorDirection = IIf(bFinish, T_CD_STRAIGHT, T_CD_NONE)
+  End If
+End Function
+
+Private Function ScanConnectorsFor(target As Visio.Shape, ByRef iSeed As Collection, ByRef iGraph As CDS_Graph, bReverseLinks As Boolean)
+  Dim iConnect As Visio.Connect
+  For Each iConnect In target.FromConnects
+    If iConnect.FromSheet.Connects.Count <> 2 Then _
+      GoTo NEXT_CONNECT
+      
+    Dim theInfo As ItemConnector: theInfo = ScanConnector(iConnect.FromSheet)
+    If bReverseLinks Then
+      If theInfo.dir_ = T_CD_STRAIGHT Then
+        theInfo.dir_ = T_CD_REVERSE
+      ElseIf theInfo.dir_ = T_CD_REVERSE Then
+        theInfo.dir_ = T_CD_STRAIGHT
+      End If
+    End If
+
+    If GraphAddEdge(iGraph, theInfo, theInfo.begin_ = target) Then
+      Dim destShape As Visio.Shape: Set destShape = IIf(theInfo.begin_ = target, theInfo.end_, theInfo.begin_)
+      Call iSeed.Add(destShape)
+    End If
+NEXT_CONNECT:
+  Next iConnect
+End Function
+
+Private Function GraphAddEdge(ByRef graph As CDS_Graph, iConnector As ItemConnector, fixedBegin As Boolean) As Boolean
+  GraphAddEdge = False
+  Select Case iConnector.dir_
+    Case T_CD_MUTUAL, T_CD_NONE:
+      Call graph.AddEdge(iConnector.begin_.ID, iConnector.end_.ID)
+      Call graph.AddEdge(iConnector.end_.ID, iConnector.begin_.ID)
+      GraphAddEdge = True
+    
+    Case T_CD_REVERSE:
+      If Not fixedBegin Then
+        Call graph.AddEdge(iConnector.end_.ID, iConnector.begin_.ID)
+        GraphAddEdge = True
+      End If
+      
+    Case T_CD_STRAIGHT:
+      If fixedBegin Then
+        Call graph.AddEdge(iConnector.begin_.ID, iConnector.end_.ID)
+        GraphAddEdge = True
+      End If
+  End Select
+End Function

visio/z_VsoUtilities.bas

@@ -0,0 +1,303 @@
+Attribute VB_Name = "z_VsoUtilities"
+' ====== Extension functions for Visio =====
+' Shared module version: 20220624
+' Tested in: TestVisio
+' Depends on: API_UndoWrapper
+' Required reference:
+Option Private Module
+Option Explicit
+
+Private Const CELLSU_STRUCTURE_TYPE = "User.msvStructureType"
+Private Const CELLSU_CONTAINER_RESIZE = "User.msvSDContainerResize"
+
+Private Const RESIZE_FIT_TO_CONTENTS = 2
+Private Const SORT_PRECISION = 1# / 25.4  ' mm to inches
+
+Public Function GlobalUndo() As API_UndoWrapper
+  Static s_Wrapper As API_UndoWrapper
+  
+  If s_Wrapper Is Nothing Then
+    Set s_Wrapper = New API_UndoWrapper
+    Call s_Wrapper.Init(Visio.Application)
+  End If
+  
+  Set GlobalUndo = s_Wrapper
+End Function
+
+Public Function FindMaster(iSource As Visio.Document, sMaster$) As Visio.Master
+  On Error Resume Next
+  Set FindMaster = iSource.Masters.Item(sMaster)
+End Function
+
+Public Function SetupFixedGridPage(target As Visio.Page)
+  With target.PageSheet
+    .CellsU("XRulerOrigin").Formula = "=GUARD(0)"
+    .CellsU("YRulerOrigin").Formula = "=GUARD(0)"
+    .CellsU("XGridOrigin").Formula = "=GUARD(XRulerOrigin)"
+    .CellsU("YGridOrigin").Formula = "=GUARD(YRulerOrigin)"
+  End With
+End Function
+
+Public Function CellsExists(target As Visio.Shape, sCellName$) As Boolean
+  CellsExists = target.CellExistsU(sCellName, visExistsAnywhere)
+End Function
+
+Public Function CellsGetValue(target As Visio.Shape, sCellName$) As Variant
+  If Not CellsExists(target, sCellName) Then _
+    Exit Function
+  CellsGetValue = target.CellsU(sCellName)
+End Function
+
+Public Function CellsSetValue(target As Visio.Shape, sCellName$, vNewValue As Variant)
+   If Not CellsExists(target, sCellName) Then _
+    Exit Function
+  target.CellsU(sCellName) = vNewValue
+End Function
+
+Public Function CellsGetFormula(target As Visio.Shape, sCellName$) As String
+  If Not CellsExists(target, sCellName) Then _
+    Exit Function
+  CellsGetFormula = target.CellsU(sCellName).Formula
+End Function
+
+Public Function CellsSetFormula(target As Visio.Shape, sCellName$, sFormula$)
+   If Not CellsExists(target, sCellName) Then _
+    Exit Function
+  target.CellsU(sCellName).Formula = sFormula
+End Function
+
+Public Function GetContainingShape(target As Visio.Shape) As Visio.Shape
+  Dim vContainer As Variant
+  For Each vContainer In target.MemberOfContainers
+    Set GetContainingShape = target.ContainingPage.Shapes.ItemFromID(vContainer)
+    Exit Function
+  Next vContainer
+End Function
+
+Public Function VsoShapeExists(sShapeName$, iWhere As Visio.Page) As Boolean
+  On Error GoTo RETURN_FALSE
+  
+  Dim iShape As Visio.Shape: Set iShape = iWhere.Shapes(sShapeName)
+  VsoShapeExists = Not iShape Is Nothing
+  Exit Function
+  
+RETURN_FALSE:
+  On Error GoTo 0
+  VsoShapeExists = False
+End Function
+
+Public Function VsoIsListContainer(target As Visio.Shape) As Boolean
+  VsoIsListContainer = CellsGetFormula(target, CELLSU_STRUCTURE_TYPE) = """List"""
+End Function
+
+Public Function VsoIsMovable(target As Visio.Shape) As Boolean
+  If target.OneD Then
+    VsoIsMovable = False
+  ElseIf CellsExists(target, CELLSU_CONTAINER_RESIZE) Then
+    VsoIsMovable = CellsGetValue(target, CELLSU_CONTAINER_RESIZE) = RESIZE_FIT_TO_CONTENTS
+  Else
+    Dim shpContainer As Visio.Shape: Set shpContainer = GetContainingShape(target)
+    If shpContainer Is Nothing Then
+      VsoIsMovable = True
+    Else
+      VsoIsMovable = Not VsoIsMovable(shpContainer)
+    End If
+  End If
+End Function
+
+Public Function VsoIsConnected(iSource As Visio.Shape, iDestination As Visio.Shape) As Boolean
+  VsoIsConnected = False
+  If iSource.OneD Then _
+    Exit Function
+  Dim iOuts() As Long: iOuts = iSource.ConnectedShapes(visConnectedShapesOutgoingNodes, "")
+  Dim nItem&
+  For nItem = LBound(iOuts) To UBound(iOuts) Step 1
+    If iOuts(nItem) = iDestination.ID Then
+      VsoIsConnected = True
+      Exit Function
+    End If
+  Next nItem
+End Function
+
+Public Function VsoApplyColorTo(target As Visio.Shape, nStart&, nEnd&, sColor$)
+  Dim iChars As Visio.Characters: Set iChars = target.Characters
+  iChars.Begin = nStart
+  iChars.End = nEnd
+  iChars.CharProps(visCharacterColor) = 1
+  
+  iChars.End = nStart + 1
+  Dim nRow&
+  Dim nPrevious&: nPrevious = -1
+  Do While iChars.End <= nEnd And iChars.Begin <> iChars.End
+    nRow = iChars.CharPropsRow(visBiasLetVisioChoose)
+    If nRow <> nPrevious Then
+      nPrevious = nRow
+      target.CellsSRC(visSectionCharacter, nRow, visCharacterColor).FormulaU = sColor
+    End If
+    
+    iChars.Begin = iChars.End
+    iChars.End = iChars.End + 1
+  Loop
+End Function
+
+' Extracts selected shapes or all shapes on ActivePage if selection is empty
+Public Function VsoActiveShapes(iSource As Visio.Application) As Collection
+  Dim iSelected As Visio.Selection: Set iSelected = iSource.ActiveWindow.Selection
+  Dim iShapes As New Collection
+  Dim aShape As Visio.Shape
+  If iSelected.Count <> 0 Then
+    For Each aShape In iSelected
+      Call iShapes.Add(aShape)
+    Next aShape
+  Else
+    For Each aShape In iSource.ActivePage.Shapes
+      Call iShapes.Add(aShape)
+    Next aShape
+  End If
+  Set VsoActiveShapes = iShapes
+End Function
+
+Public Function VsoGetSelectedShapes(vsoAppl As Visio.Application)
+  Dim iShapes As New Collection
+  Dim iSelection As Visio.Selection: Set iSelection = vsoAppl.ActiveWindow.Selection
+  Dim iShape As Visio.Shape
+  For Each iShape In iSelection
+    Call iShapes.Add(iShape)
+  Next iShape
+  Set VsoGetSelectedShapes = iShapes
+End Function
+
+Public Function VsoSelectShapes(iShapes As Collection, iPage As Visio.Page)
+  ActiveWindow.Page = iPage
+  Dim iSelection As Visio.Selection: Set iSelection = ActiveWindow.Selection
+  Call iSelection.DeselectAll
+  Dim iShape As Visio.Shape
+  For Each iShape In iShapes
+    Call iSelection.Select(iShape, visSelect)
+  Next iShape
+  ActiveWindow.Selection = iSelection
+End Function
+
+Public Function VsoSelectShapesIDs(iShapeIDs As Collection, iPage As Visio.Page)
+  Dim iSelection As Visio.Selection: Set iSelection = iPage.Application.ActiveWindow.Selection
+  Call iSelection.DeselectAll
+  Dim nShapeID As Variant
+  For Each nShapeID In iShapeIDs
+    Call iSelection.Select(iPage.Shapes.ItemFromID(CLng(nShapeID)), visSelect)
+  Next nShapeID
+  iPage.Application.ActiveWindow.Selection = iSelection
+End Function
+
+Public Function VsoClearPage(target As Visio.Page)
+  Do While target.Shapes.Count > 0
+    Call target.Shapes(1).Delete
+  Loop
+End Function
+
+Public Function VsoShowWholePage(target As Visio.Page)
+  target.Application.ActiveWindow.Page = target
+  target.Application.ActiveWindow.ViewFit = visFitPage
+End Function
+
+Public Function VsoCenterViewOn(target As Visio.Shape)
+  Call target.Application.ActiveWindow.ScrollViewTo(target.CellsU("PinX"), target.CellsU("PinY"))
+End Function
+
+Public Function VsoIncrementWidth(target As Visio.Shape, valueInMM&)
+  If target.OneD Then _
+    Exit Function
+  If TryIncrementContained(target, valueInMM) Then _
+    Exit Function
+  
+  Dim dWidth As Double: dWidth = target.CellsU("Width")
+  If VsoIsListContainer(target) Then
+    Dim iMember As Visio.Shape
+    Dim memberID As Variant
+    For Each memberID In target.ContainerProperties.GetListMembers
+      Set iMember = target.ContainingPage.Shapes.ItemFromID(memberID)
+      Call iMember.Resize(visResizeDirE, valueInMM, visMillimeters)
+    Next memberID
+  End If
+  If dWidth = target.CellsU("Width") Then _
+    Call target.Resize(visResizeDirE, valueInMM, visMillimeters)
+End Function
+
+Public Function VsoCalculateFillingFor(target As Visio.Page) As Double
+' returns percentage of used space on the page
+' does not account for shapes overlapping
+  Dim sumAreas As Double: sumAreas = 0
+  Dim aShape As Visio.Shape
+  For Each aShape In target.Shapes
+    If VsoIsMovable(aShape) Then _
+      sumAreas = sumAreas + aShape.CellsU("Width") * aShape.CellsU("Height")
+  Next aShape
+  
+  Dim dSheetArea As Double
+  dSheetArea = target.PageSheet.CellsU("PageWidth") * target.PageSheet.CellsU("PageHeight")
+  
+  If dSheetArea <> 0 Then _
+    VsoCalculateFillingFor = sumAreas / dSheetArea
+End Function
+
+' Sort by topmost and leftmost position of a shape
+Public Function VsoGeometricSort(ByRef target() As Long, iPage As Visio.Page)
+  If Not IsArrayAllocated(target) Then _
+    Exit Function
+  Call GeometricQuickSort(iPage, target, LBound(target, 1), UBound(target, 1))
+End Function
+
+' ==========
+Private Function TryIncrementContained(target As Visio.Shape, valueInMM&) As Boolean
+  TryIncrementContained = False
+  Dim wrapper As Visio.Shape: Set wrapper = GetContainingShape(target)
+  If wrapper Is Nothing Then _
+    Exit Function
+  If Not VsoIsListContainer(wrapper) Then _
+    Exit Function
+  
+  Call VsoIncrementWidth(wrapper, valueInMM)
+  TryIncrementContained = True
+End Function
+
+Private Function GeometricQuickSort(iPage As Visio.Page, ByRef target() As Long, ByVal nLow&, ByVal nHigh&)
+  Do While nLow < nHigh
+    Dim nPivot&: nPivot = GSPartition(iPage, target, nLow, nHigh)
+    Call GeometricQuickSort(iPage, target, nLow, nPivot - 1)
+    nLow = nPivot + 1
+  Loop
+End Function
+
+Private Function GSPartition(iPage As Visio.Page, ByRef target() As Long, nLow&, nHigh&) As Long
+  Dim iPivot As Visio.Shape: Set iPivot = iPage.Shapes.ItemFromID(target(nHigh))
+  Dim nSmallest&: nSmallest = nLow - 1
+  Dim iTempValue As Variant
+  
+  Dim n&
+  For n = nLow To nHigh - 1
+    Dim iShape As Visio.Shape: Set iShape = iPage.Shapes.ItemFromID(target(n))
+    If GeometricCompare(iShape, iPivot) < 0 Then
+      nSmallest = nSmallest + 1
+      iTempValue = target(nSmallest)
+      target(nSmallest) = target(n)
+      target(n) = iTempValue
+    End If
+  Next n
+  
+  nSmallest = nSmallest + 1
+  iTempValue = target(nSmallest)
+  target(nSmallest) = target(nHigh)
+  target(nHigh) = iTempValue
+  
+  GSPartition = nSmallest
+End Function
+
+Private Function GeometricCompare(iShape1 As Visio.Shape, iShape2 As Visio.Shape) As Double
+  GeometricCompare = iShape2.CellsU("PinY") + iShape2.CellsU("Height") / 2# - iShape1.CellsU("PinY") - iShape1.CellsU("Height") / 2#
+  If Abs(GeometricCompare) > SORT_PRECISION Then _
+    Exit Function
+  GeometricCompare = iShape1.CellsU("PinX") - iShape1.CellsU("Width") / 2# - iShape2.CellsU("PinX") + iShape2.CellsU("Width") / 2#
+  If Abs(GeometricCompare) > SORT_PRECISION Then _
+    Exit Function
+  GeometricCompare = 0
+End Function
+

word/API_WordEditGuard.cls

@@ -0,0 +1,219 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "API_WordEditGuard"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+' ========= Îáîëî÷êà äëÿ ðåäàêòèðîâàíèÿ äîêóìåíòà â Ìàñòåðå Òåêñòîâ ===================
+' Shared module version: 20220613
+' Tested in:
+' Depends on: API_WordWrapper
+' Required reference: Word
+Option Explicit
+
+' Note: should synchronize with DocumentEditor
+Private Const ERROR_HIGHLIGHT_COLOR = wdViolet
+
+Private Const AUTOMATON_USER_NAME = "Ìàñòåð òåêñòîâ"
+Private Const AUTOMATON_USER_INIT = "ÌÒ"
+
+Private Const IGNORE_BM_PREFIX = "zIGNORE_"
+Private Const AUTO_COMMENT_PREFIX = "AR"
+
+Private document_ As Word.Document
+Private word_ As API_WordWrapper
+
+Private userName_ As String
+Private userInitials_ As String
+Private trackRevisions_ As Boolean
+Private includeHiddenText_ As Boolean
+Private includeFieldCodes_ As Boolean
+Private deletedTextMark_ As WdDeletedTextMark
+Private noProofing_ As Boolean
+
+Private Sub Class_Terminate()
+  Set document_ = Nothing
+End Sub
+
+Public Function Init(target As API_WordWrapper)
+  Set document_ = target.Document
+  Set word_ = target
+End Function
+
+Public Function InitDoc(target As Word.Document)
+  Set document_ = target
+  Set word_ = Nothing
+End Function
+
+Public Property Get Document() As Word.Document
+  Set Document = document_
+End Property
+
+Public Property Get Wrapper() As API_WordWrapper
+  Set Wrapper = word_
+End Property
+
+Public Function BeginEdit(bTrackRevisions As Boolean)
+  With document_
+    userName_ = .Application.UserName
+    userInitials_ = .Application.UserInitials
+    trackRevisions_ = .TrackRevisions
+    includeHiddenText_ = .Range.TextRetrievalMode.IncludeHiddenText
+    includeFieldCodes_ = .Range.TextRetrievalMode.IncludeFieldCodes
+    deletedTextMark_ = .Application.Options.DeletedTextMark
+    noProofing_ = .Range.NoProofing
+  
+    .ActiveWindow.View.ReadingLayout = False
+    .Range.NoProofing = True
+    .Application.ScreenUpdating = False
+  End With
+  
+  Call HideIgnored
+  Call ClearExistingFormat
+  
+  On Error Resume Next  ' Ñðàáàòûâàåò, åñëè îôèñ íå 2013 è ïàðàìåòðà Options.UseLocalUserInfo íå ñóùåñòâóåò
+  With document_
+    .TrackRevisions = bTrackRevisions
+    .Range.TextRetrievalMode.IncludeHiddenText = False
+    .Range.TextRetrievalMode.IncludeFieldCodes = False
+    .Application.Options.DeletedTextMark = wdDeletedTextMarkHidden
+    
+    .Application.UserName = AUTOMATON_USER_NAME
+    .Application.UserInitials = AUTOMATON_USER_INIT
+    .Application.Options.UseLocalUserInfo = True
+  End With
+  On Error GoTo 0
+End Function
+
+Public Function EndEdit()
+  If userName_ = vbNullString Then _
+    userName_ = VBA.Environ("username")
+    
+  On Error Resume Next
+  With document_
+    .TrackRevisions = trackRevisions_
+    Call UnHideIgnored
+    
+    .Application.UserName = userName_
+    .Application.UserInitials = userInitials_
+    .Range.TextRetrievalMode.IncludeHiddenText = includeHiddenText_
+    .Range.TextRetrievalMode.IncludeFieldCodes = includeFieldCodes_
+    .Application.Options.DeletedTextMark = deletedTextMark_
+    .Range.NoProofing = noProofing_
+    
+    .Application.ScreenUpdating = True
+    Call .Application.ScreenRefresh
+  End With
+End Function
+
+Public Function SaveAndShowDiff()
+  Dim oldName$: oldName = document_.FullName
+  Dim newName$: newName = oldName
+  newName = VBA.Left(newName, VBA.Len(newName) - VBA.Len(".docx"))
+  newName = newName & "_" & VBA.Format(VBA.Now(), "MMddhhmm") & ".docx"
+  Call document_.SaveAs(newName)
+  
+  Dim iWrap As New API_WordWrapper: Call iWrap.OpenDocument(oldName)
+  Call document_.Application.CompareDocuments(iWrap.Document, document_, _
+        Destination:=wdCompareDestinationNew, _
+        CompareFields:=False, _
+        RevisedAuthor:=AUTOMATON_USER_NAME)
+End Function
+
+Public Function BookmarkIgnored(target As Word.Range) As String
+  Dim nIndex&: nIndex = document_.Bookmarks.Count + 1
+  Dim sBookmark$: sBookmark = IGNORE_BM_PREFIX & nIndex
+  Do While document_.Bookmarks.Exists(sBookmark)
+    nIndex = nIndex - 1
+    sBookmark = IGNORE_BM_PREFIX & nIndex
+  Loop
+  
+  BookmarkIgnored = sBookmark
+  If target.Bookmarks.Add(sBookmark, target) Is Nothing Then _
+    Call Err.Raise(vbObjectError)
+End Function
+
+' ==============
+Private Function HideIgnored()
+' Ñêðûâàåì èãíîðèðóåìûå ÷àñòè òåêñòà
+  Dim trackRev As Boolean: trackRev = document_.TrackRevisions
+  document_.TrackRevisions = False
+
+  Dim aBookmark As Word.Bookmark
+  For Each aBookmark In document_.Bookmarks
+    If IsBookmarkIgnored(aBookmark.Name) Then _
+      aBookmark.Range.Font.Hidden = True
+  Next aBookmark
+  
+  document_.TrackRevisions = trackRev
+End Function
+
+Private Function UnHideIgnored()
+' Îòîáðàæàåì èãíîðèðóåìûå ÷àñòè òåêñòà
+  Dim trackRev As Boolean: trackRev = document_.TrackRevisions
+  document_.TrackRevisions = False
+  
+  Dim aBookmark As Word.Bookmark
+  For Each aBookmark In document_.Bookmarks
+    If IsBookmarkIgnored(aBookmark.Name) Then _
+      aBookmark.Range.Font.Hidden = False
+  Next aBookmark
+  
+  document_.TrackRevisions = trackRev
+End Function
+
+Private Function IsBookmarkIgnored(sBookmark$) As Boolean
+  IsBookmarkIgnored = sBookmark Like IGNORE_BM_PREFIX & "*"
+End Function
+
+Private Function ClearExistingFormat()
+' Î÷èùàåì ôîðìàòèðîâàíèå â äîêóìåíòå
+  Dim trackRev As Boolean: trackRev = document_.TrackRevisions
+  document_.TrackRevisions = False
+  
+  ' Î÷èùàåì âûäåëåíèå öâåòîì ññûëîê íà òåðìèíû
+  Dim rFind As Word.Range: Set rFind = document_.Range
+  Dim nStart&: nStart = -1
+  With rFind.Find
+    .Forward = True
+    .Font.Hidden = False
+    .Highlight = True
+    .Format = True
+    .MatchPhrase = False
+    .MatchCase = False
+    .MatchWholeWord = False
+    .MatchWildcards = False
+  End With
+  
+  Do While rFind.Find.Execute
+    If rFind.HighlightColorIndex = ERROR_HIGHLIGHT_COLOR Then
+      rFind.HighlightColorIndex = wdNoHighlight
+    End If
+    
+    Call rFind.Collapse(wdCollapseEnd)
+    
+    If nStart = rFind.Start Then  ' Ãàðàíòèðóåì, ÷òî íå çàöèêëèìñÿ
+      Debug.Print "Î÷èñòêà òåêñòà çàöèêëèëàñü"
+      Exit Do
+    Else
+      nStart = rFind.Start
+    End If
+  Loop
+  
+  Dim i&: i = 1
+  Do While True
+    If i > document_.Comments.Count Then _
+      Exit Do
+    
+    If VBA.Left(document_.Comments(i).Range.Text, 2) = AUTO_COMMENT_PREFIX Then
+      document_.Comments(i).Delete
+    Else
+      i = i + 1
+    End If
+  Loop
+  
+  document_.TrackRevisions = trackRev
+End Function

word/ex_Word.bas

@@ -0,0 +1,226 @@
+Attribute VB_Name = "ex_Word"
+'================ Word helper functions =============
+' Shared module version: 20220911
+' Tested in: TestWord
+' Depends on:
+' Required reference:
+Option Private Module
+Option Explicit
+
+Public Function WordIntersectRanges(rng1 As Word.Range, rng2 As Word.Range) As Word.Range
+  If rng1.Document <> rng2.Document Then _
+    Exit Function
+  If rng1.Start >= rng2.End Or rng2.Start >= rng1.End Then _
+    Exit Function
+  If rng1.Start >= rng2.Start Then
+    If rng2.End > rng1.Start Then _
+      Set WordIntersectRanges = rng1.Document.Range(rng1.Start, IIf(rng1.End > rng2.End, rng2.End, rng1.End))
+  Else
+    If rng1.End > rng2.Start Then _
+      Set WordIntersectRanges = rng1.Document.Range(rng2.Start, IIf(rng1.End > rng2.End, rng2.End, rng1.End))
+  End If
+End Function
+
+Public Function WordPutText(sText$, iDoc As Word.Document, nWhere&, Optional aStyle$ = vbNullString) As Word.Range
+  Set WordPutText = iDoc.Range(nWhere, nWhere)
+  With WordPutText
+    Call .InsertAfter(sText)
+    If aStyle <> vbNullString Then _
+      .Style = aStyle
+  End With
+End Function
+
+Public Function WordAppendTo(sText$, ByRef rWhere As Word.Range, Optional aStyle$ = vbNullString) As Word.Range
+  Const ASCII_NEWLINE = 13
+  
+  If rWhere.Characters.Count > 0 Then _
+    If AscW(rWhere.Characters.Last) = ASCII_NEWLINE Then _
+      Call rWhere.MoveEnd(wdCharacter, -1)
+  
+  Call rWhere.InsertAfter(sText)
+  Dim insertedRng As Word.Range: Set insertedRng = rWhere.Duplicate
+  insertedRng.Start = rWhere.End - VBA.Len(sText)
+  If aStyle <> vbNullString Then _
+    insertedRng.Style = aStyle
+  Set WordAppendTo = insertedRng
+End Function
+
+Public Function WordAddLine(sText$, rWhere As Word.Range, Optional aStyle$ = vbNullString) As Word.Range
+  Dim nEnd&: nEnd = rWhere.End
+  If rWhere.Tables.Count > 0 Then
+    If rWhere.Cells.Count > 0 Then
+      Dim theLastCell As Word.Cell: Set theLastCell = rWhere.Cells(rWhere.Cells.Count)
+      If nEnd >= theLastCell.Range.End - 1 Then
+        Set WordAddLine = AddLineLastInCell(sText, theLastCell, aStyle)
+        GoTo SAFE_EXIT
+      End If
+    End If
+  End If
+  
+  Dim nParaEnd&: nParaEnd = rWhere.Paragraphs.Last.Range.End
+  If rWhere.End = rWhere.Document.Range.End Then
+    Call rWhere.InsertAfter(vbNewLine)
+    Set WordAddLine = WordPutText(sText, rWhere.Document, rWhere.End - 1, aStyle)
+    Call WordAddLine.MoveEnd(wdCharacter, 1)
+    GoTo SAFE_EXIT
+  End If
+  
+  If nEnd <> nParaEnd Then
+    If rWhere.Next(wdCharacter, 1).End = nParaEnd Then
+      Call rWhere.MoveEnd(wdCharacter, 1)
+    Else
+      Call rWhere.InsertAfter(vbNewLine)
+    End If
+  End If
+  Set WordAddLine = WordPutText(sText & vbNewLine, rWhere.Document, rWhere.End, aStyle)
+  
+SAFE_EXIT:
+  rWhere.End = nEnd
+End Function
+
+Public Function WordFindAndReplace(iDoc As Word.Document, findText$, ReplaceText$, _
+                            Optional mCase As Boolean = False, _
+                            Optional wildCard As Boolean = False, _
+                            Optional wholeWord As Boolean = True) As Long
+  Dim findRange As Word.Range: Set findRange = iDoc.Range
+  Dim nResult&: nResult = 0
+  With findRange.Find
+    .Text = findText
+    .MatchCase = mCase
+    .MatchWholeWord = wholeWord
+    .MatchWildcards = wildCard
+    .Replacement.Text = ReplaceText
+    .Format = True
+    .Font.Hidden = False
+    
+    Do While .Execute(Replace:=1)
+      nResult = nResult + 1
+      Call findRange.Collapse(Direction:=wdCollapseEnd)
+    Loop
+  End With
+  WordFindAndReplace = nResult
+End Function
+
+Public Function WordDeleteHyperlinks(iDoc As Word.Document) As Long
+  On Error Resume Next
+  WordDeleteHyperlinks = 0
+  Do Until iDoc.Hyperlinks.Count = 0
+    Call iDoc.Hyperlinks(1).Delete
+    WordDeleteHyperlinks = WordDeleteHyperlinks + 1
+  Loop
+End Function
+
+Public Function WordStyleExists(iDoc As Word.Document, target$) As Boolean
+  WordStyleExists = True
+  On Error GoTo RET_FALSE
+  Dim aStyle As Word.Style: Set aStyle = iDoc.Styles(target)
+  Exit Function
+  
+RET_FALSE:
+  WordStyleExists = False
+End Function
+
+' Requires: wordApp should be Application, responsible for both documents (if any or both are open)
+Public Function WordCopyStyle(wordApp As Word.Application, sSource$, sDestination$, sStyle$) As Boolean
+  WordCopyStyle = True
+  On Error GoTo RETURN_FALSE
+  Call wordApp.OrganizerCopy(sSource, sDestination, sStyle, wdOrganizerObjectStyles)
+  On Error GoTo 0
+  Exit Function
+RETURN_FALSE:
+  WordCopyStyle = False
+End Function
+
+Public Function WordStyleIsUsed(iDoc As Word.Document, aStyle As Word.Style) As Boolean
+  On Error Resume Next
+  Dim findRange As Word.Range: Set findRange = iDoc.Range
+  With findRange.Find
+    .Text = vbNullString
+    .Format = True
+    .Style = aStyle
+    WordStyleIsUsed = .Execute
+  End With
+End Function
+
+Public Function WordAdjustRange(target As Word.Range) As Word.Range
+  Dim rExpansion As Word.Range: Set rExpansion = target.Duplicate
+  If Not rExpansion.Characters.First Like "[" & " " & Chr(160) & "]" Then
+    Call rExpansion.StartOf(wdWord, wdExtend)
+    Call rExpansion.MoveStartWhile("""'«»“”", wdBackward)
+  End If
+  
+  If rExpansion.Start <> rExpansion.End Then _
+    Call rExpansion.EndOf(wdWord, wdExtend)
+  
+  If Not rExpansion.Characters.Last Like "[" & " " & Chr(160) & "]" Then
+    Call rExpansion.MoveEndWhile("""'«»“”", wdForward)
+    Call rExpansion.MoveEndWhile(" " & Chr(160), wdForward)
+  End If
+
+  Set WordAdjustRange = rExpansion
+End Function
+
+Public Function AcceptAuthorsRevision(oAuthors As Collection, target As Word.Document) As Long
+  AcceptAuthorsRevision = 0
+  Dim itemChange As Word.Revision
+  For Each itemChange In target.Revisions
+    Dim sAuthor As Variant
+    For Each sAuthor In oAuthors
+      If sAuthor = itemChange.Author Then
+        Call itemChange.Accept
+        AcceptAuthorsRevision = AcceptAuthorsRevision + 1
+        GoTo NEXT_ITEM
+      End If
+    Next sAuthor
+NEXT_ITEM:
+  Next itemChange
+End Function
+
+Public Function AcceptFormatRevision(iDoc As Word.Document) As Long
+  AcceptFormatRevision = 0
+  Dim itemChange As Word.Revision
+  Dim theType As WdRevisionType
+  For Each itemChange In iDoc.Revisions
+    theType = itemChange.Type
+    If theType = wdRevisionParagraphProperty Or _
+       theType = wdRevisionStyle Or _
+       theType = wdRevisionProperty Then
+      itemChange.Accept
+      AcceptFormatRevision = AcceptFormatRevision + 1
+    End If
+  Next itemChange
+End Function
+
+Public Function StyleByName(sStyle$, iDoc As Word.Document) As Word.Style
+  On Error GoTo RETURN_NOTHING
+  Set StyleByName = iDoc.Styles(sStyle)
+RETURN_NOTHING:
+End Function
+
+Public Function ExtractCommentText(target As Word.Range) As String
+  If target.Comments.Count <> 0 Then
+    ExtractCommentText = target.Comments(1).Range.Text
+    Exit Function
+  End If
+  
+  Dim theDoc As Word.Document: Set theDoc = target.Document
+  Dim aComment As Word.Comment
+  For Each aComment In theDoc.Comments
+    If target.InRange(aComment.Scope) Then
+      ExtractCommentText = aComment.Range.Text
+      Exit Function
+    End If
+  Next aComment
+  ExtractCommentText = vbNullString
+End Function
+
+' =====
+Private Function AddLineLastInCell(sText$, whereCell As Word.Cell, aStyle$) As Word.Range
+  Dim nWhere&: nWhere = whereCell.Range.End - 1
+  If whereCell.Range.Characters.Count > 1 Then
+    Call WordPutText(vbNewLine, whereCell.Range.Document, nWhere)
+    nWhere = nWhere + 1
+  End If
+  Set AddLineLastInCell = WordPutText(sText, whereCell.Range.Document, whereCell.Range.End - 1, aStyle)
+End Function
+