Internals/VBCommons
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial commit

Browse Source
This commit is contained in:
IRBorisov 2024-06-07 20:46:40 +03:00
commit 152c6e471e
98 changed files with 12635 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored Normal file
View File

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

183
api/API_Path.cls Normal file
View File

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

235
api/API_Project.cls Normal file
View File

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

221
api/API_Python.cls Normal file
View File

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

85
api/API_Ribbon.cls Normal file
View File

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

121
api/API_UserInteraction.cls Normal file
View File

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

376
api/API_VsoWrapper.cls Normal file
View File

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

394
api/API_WordWrapper.cls Normal file
View File

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

412
api/API_XLWrapper.cls Normal file
View File

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

117
api/ex_ConceptCore.bas Normal file
View File

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

40
api/ex_Metadata.bas Normal file
View File

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

125
api/ex_Python.bas Normal file
View File

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

541
api/ex_WinAPI.bas Normal file
View File

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

97
api/z_LoadPictureAPI.bas Normal file
View File

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

156
api/z_PastePictureAPI.bas Normal file
View File

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

96
dev/API_Logger.cls Normal file
View File

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

247
dev/API_MockInteraction.cls Normal file
View File

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

119
dev/API_TestRunner.cls Normal file
View File

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

16
dev/CDS_InfoFunction.cls Normal file
View File

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

33
dev/CDS_InfoTests.cls Normal file
View File

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

679
dev/DevTester.bas Normal file
View File

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

21
dev/DevTesterUI.bas Normal file
View File

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

194
dev/DevTools.bas Normal file
View File

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

84
dev/ex_ConceptOrganization.bas Normal file
View File

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

49
excel/API_XLRecordsWrapper.cls Normal file
View File

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

151
excel/ex_Excel.bas Normal file
View File

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

50
parsers/DetectorClassifier.cls Normal file
View File

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

105
parsers/DetectorListWords.cls Normal file
View File

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

47
parsers/DetectorMorpho.cls Normal file
View File

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

42
parsers/DetectorRegex.cls Normal file
View File

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

44
parsers/ExtractionOptions.cls Normal file
View File

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

34
parsers/PC_Fragment.cls Normal file
View File

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

58
parsers/PC_InfoNPA.cls Normal file
View File

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

42
parsers/PC_ParsedData.cls Normal file
View File

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

127
parsers/PC_Tools.cls Normal file
View File

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

151
parsers/ParserDate.cls Normal file
View File

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

54
parsers/ParserDeclarations.bas Normal file
View File

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

179
parsers/ParserNPA.cls Normal file
View File

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

232
parsers/z_ParserRegex.bas Normal file
View File

@ -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]+"

BIN
samples/20150923 Таймлайнер.xlsm Normal file
View File

Binary file not shown.

BIN
samples/20180725 Технология разметки.docm Normal file
View File

Binary file not shown.

BIN
samples/20200214 Иерархизатор 3.5.vsdm Normal file
View File

Binary file not shown.

BIN
samples/20200214 Подстановки Visio.xlsm Normal file
View File

Binary file not shown.

BIN
samples/20200225 Блоки_v1.1.vsdm Normal file
View File

Binary file not shown.

57
samples/DB_Data_sample.cls Normal file
View File

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

20
samples/DevHelper_sample.bas Normal file
View File

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

81
samples/Iterator_sample.cls Normal file
View File

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

31
samples/VBAMake_sample.txt Normal file
View File

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

38
samples/manifest_sample.txt Normal file
View File

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

31
samples/s_Test_sample.cls Normal file
View File

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

71
samples/z_UIMessages_sample.bas Normal file
View File

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

15
samples/z_UIRibbon_sample.bas Normal file
View File

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

198
ui/CSE_ListSelector.frm Normal file
View File

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

BIN
ui/CSE_ListSelector.frx Normal file
View File

Binary file not shown.

329
ui/CSE_ProgressBar.frm Normal file
View File

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

BIN
ui/CSE_ProgressBar.frx Normal file
View File

Binary file not shown.

483
ui/Calendar/CSE_Calendar.frm Normal file
View File

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

BIN
ui/Calendar/CSE_Calendar.frx Normal file
View File

Binary file not shown.

53
ui/Calendar/CSE_CallbackCalendar.cls Normal file
View File

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

49
ui/Calendar/z_CalendarUI.bas Normal file
View File

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

2
ui/ribbonVSO/.rels Normal file
View File

@ -0,0 +1,2 @@
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships"><Relationship Id="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>

16
ui/ribbonVSO/customUI1.xml Normal file
View File

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

2
ui/ribbonWord/.rels Normal file
View File

@ -0,0 +1,2 @@
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships"><Relationship Id="rId1" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument" Target="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>

16
ui/ribbonWord/customUI.xml Normal file
View File

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

2
ui/ribbonXL/.rels Normal file
View File

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

16
ui/ribbonXL/customUI.xml Normal file
View File

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

103
utility/API_Config.cls Normal file
View File

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

73
utility/API_DistrManifest.cls Normal file
View File

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

360
utility/API_GraphOrdering.cls Normal file
View File

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

618
utility/API_JSON.cls Normal file
View File

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

61
utility/API_LinkedComponents.cls Normal file
View File

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

101
utility/API_StrongComponents.cls Normal file
View File

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

63
utility/API_Timer.cls Normal file
View File

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

67
utility/CDS_CompoundIntervals.cls Normal file
View File

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

48
utility/CDS_Edge.cls Normal file
View File

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

76
utility/CDS_Factorizator.cls Normal file
View File

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

172
utility/CDS_Graph.cls Normal file
View File

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

34
utility/CDS_Interval.cls Normal file
View File

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

19
utility/CDS_Node.cls Normal file
View File

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

33
utility/CDS_NodeSH.cls Normal file
View File

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

78
utility/CDS_StaticHierarchy.cls Normal file
View File

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

138
utility/ex_Collection.bas Normal file
View File

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

298
utility/ex_Color.bas Normal file
View File

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

345
utility/ex_DataPreparation.bas Normal file
View File

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

29
utility/ex_Hash.bas Normal file
View File

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

74
utility/ex_MSHook.bas Normal file
View File

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

108
utility/ex_Regex.bas Normal file
View File

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

180
utility/ex_Time.bas Normal file
View File

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

469
utility/ex_VBA.bas Normal file
View File

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

130
utility/ex_Version.bas Normal file
View File

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

30
utility/z_QuickSort.bas Normal file
View File

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

102
visio/API_ShapeStorage.cls Normal file
View File

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

45
visio/API_UndoWrapper.cls Normal file
View File

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

432
visio/z_CCVsoExtension.bas Normal file
View File

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

132
visio/z_VsoGraph.bas Normal file
View File

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

303
visio/z_VsoUtilities.bas Normal file
View File

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

219
word/API_WordEditGuard.cls Normal file
View File

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

226
word/ex_Word.bas Normal file
View File

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