commit 152c6e471ea40d9e47367010e44f77cf1487571e Author: IRBorisov <8611739+IRBorisov@users.noreply.github.com> Date: Fri Jun 7 20:46:40 2024 +0300 Initial commit diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..66825a4 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +~* + diff --git a/api/API_Path.cls b/api/API_Path.cls new file mode 100644 index 0000000..b22a6bb --- /dev/null +++ b/api/API_Path.cls @@ -0,0 +1,183 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "API_Path" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ================ Работа с путями к файлам ============= +' Shared module version: 20221031 +' Tested in: TestCommons +' Depends on: ex_VBA +' Required reference: Scripting +Option Explicit + +Private Enum PathType + T_PATH_INVALID = 0 + + T_PATH_GLOBAL = 1 + T_PATH_LOCAL = 2 + T_PATH_ENVIRON = 3 +End Enum + +Private data_ As String +Private type_ As PathType + +Public Function FromString(sText$) As API_Path + data_ = sText + type_ = InternalEvaluate(data_) + Set FromString = Me +End Function + +Public Function Clone() As API_Path + Set Clone = New API_Path + Call Clone.FromString(data_) +End Function + +Public Property Get Text() As String + Text = data_ +End Property + +Public Property Get ParentFolder() As String + Dim fso As New Scripting.FileSystemObject + ParentFolder = fso.GetParentFolderName(data_) +End Property + +Public Property Get FileName() As String + Dim fso As New Scripting.FileSystemObject + FileName = fso.GetFileName(data_) +End Property + +Public Property Get BaseName() As String + Dim fso As New Scripting.FileSystemObject + BaseName = fso.GetBaseName(data_) +End Property + +Public Property Get Extension() As String + Dim fso As New Scripting.FileSystemObject + Extension = fso.GetExtensionName(data_) +End Property + +Public Function ToGlobal(sHome$) As API_Path + Select Case type_ + Case T_PATH_LOCAL: data_ = ConvertLocal(data_, sHome) + Case T_PATH_ENVIRON: data_ = ConvertEnviron(data_) + Case T_PATH_INVALID, T_PATH_GLOBAL: + End Select + type_ = InternalEvaluate(data_) + Set ToGlobal = Me +End Function + +Public Function ToLocal(sHome$) As API_Path + Set ToLocal = Me + Dim nPrefix&: nPrefix = CommonPrefixLength(data_, sHome, vbTextCompare) + If nPrefix = 0 Then _ + Exit Function + + If VBA.Mid(data_, nPrefix, 1) = "\" Then + nPrefix = nPrefix - 1 + ElseIf VBA.Mid(data_, nPrefix + 1, 1) <> "\" Then + nPrefix = VBA.InStrRev(data_, "\", nPrefix) + If nPrefix < 3 Then _ + Exit Function + End If + + Dim fso As New Scripting.FileSystemObject + Dim sFolder$: sFolder = sHome + Dim sPrefix$ + Do While VBA.Len(sFolder) > nPrefix + sFolder = fso.GetParentFolderName(sFolder) + sPrefix = sPrefix & "..\" + Loop + + data_ = VBA.Right(data_, VBA.Len(data_) - nPrefix - 1) + If sPrefix <> vbNullString Then _ + data_ = sPrefix & data_ + type_ = InternalEvaluate(data_) +End Function + +Public Function ToServer(sHome$) As API_Path + Call ToGlobal(sHome) + data_ = SubstituteServer(data_) + type_ = InternalEvaluate(data_) + Set ToServer = Me +End Function + +Public Function GlobalToServer() As API_Path + data_ = SubstituteServer(data_) + type_ = InternalEvaluate(data_) + Set GlobalToServer = Me +End Function + +Public Function LocalExists(sHome$) As Boolean + Dim sFile$ + If type_ = T_PATH_LOCAL Then + sFile = ConvertLocal(data_, sHome) + Else + sFile = data_ + End If + LocalExists = CheckPath(sFile) +End Function + +Public Function GlobalExists() As Boolean + GlobalExists = CheckPath(data_) +End Function + +' ======== +Private Function InternalEvaluate(sPath$) As PathType + If VBA.Len(sPath) < 3 Then + InternalEvaluate = T_PATH_INVALID + ElseIf VBA.Mid(sPath, 2, 1) = ":" Or VBA.Left(sPath, 2) = "\\" Then + InternalEvaluate = T_PATH_GLOBAL + ElseIf sPath Like "%*%*" Then + InternalEvaluate = T_PATH_ENVIRON + Else + InternalEvaluate = T_PATH_LOCAL + End If +End Function + +Private Function SubstituteServer(sPath$) As String + If VBA.Len(sPath) < 3 Then + SubstituteServer = sPath + ElseIf VBA.Left(sPath, 3) = "P:\" Then + SubstituteServer = "\\fs1.concept.ru\projects\" & VBA.Right(sPath, VBA.Len(sPath) - 3) + ElseIf VBA.Left(sPath, 3) = "X:\" Then + SubstituteServer = "\\fs1.concept.ru\Exchange\" & VBA.Right(sPath, VBA.Len(sPath) - 3) + Else + SubstituteServer = sPath + End If +End Function + +Private Function ConvertLocal(sPath$, sHome$) As String + Dim nEllipsis&: nEllipsis = VBA.InStrRev(sPath, "..\") + If nEllipsis = 0 Then + ConvertLocal = sHome & "\" & sPath + Else + Dim fso As New Scripting.FileSystemObject + Dim nCount&: nCount = 1 + nEllipsis / 3 + Dim sFolder$: sFolder = sHome + Do While nCount > 0 + sFolder = fso.GetParentFolderName(sFolder) + nCount = nCount - 1 + Loop + ConvertLocal = sFolder & "\" & VBA.Right(sPath, VBA.Len(sPath) - nEllipsis - 2) + End If +End Function + +Private Function ConvertEnviron(sPath$) As String + Dim nHeader&: nHeader = VBA.InStr(2, sPath, "%") + Dim sVariable$: sVariable = VBA.Mid(sPath, 2, nHeader - 2) + ConvertEnviron = VBA.Environ$(sVariable) & "\" & VBA.Right(sPath, VBA.Len(sPath) - nHeader - 1) +End Function + +Private Function CheckPath(sPath$) As Boolean + Dim fso As New Scripting.FileSystemObject + CheckPath = True + If fso.FileExists(sPath) Then _ + Exit Function + If fso.FolderExists(sPath) Then _ + Exit Function + CheckPath = False +End Function diff --git a/api/API_Project.cls b/api/API_Project.cls new file mode 100644 index 0000000..796b909 --- /dev/null +++ b/api/API_Project.cls @@ -0,0 +1,235 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "API_Project" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ================ Import / export code functionality ============= +' Shared module version: 20220407 +' Tested in: +' Depends on: +' Required reference: Scripting, VBIDE +Option Explicit + +Private fso_ As Scripting.FileSystemObject +Private proj_ As VBIDE.VBProject + +Private contents_ As Scripting.Dictionary +Private sharedContents_ As Scripting.Dictionary + +Private sourceHome_ As String +Private importsHome_ As String + +Private Sub Class_Initialize() + Set fso_ = New Scripting.FileSystemObject +End Sub + +Private Sub Class_Terminate() + Call Detach +End Sub + +Public Function Init(target As VBIDE.VBProject, Optional sImportsHome$ = "") As Boolean + Init = target.Protection <> 1 + If Not Init Then + Call MsgBox("Project code is protected, cannot acccess", vbCritical) + Exit Function + End If + + Set proj_ = target + importsHome_ = sImportsHome + + Set contents_ = New Scripting.Dictionary + Set sharedContents_ = New Scripting.Dictionary +End Function + +Public Function Detach() + Set proj_ = Nothing + importsHome_ = "" +End Function + +Public Function SetInternals(ByRef oContents As Scripting.Dictionary, _ + ByRef oSharedCont As Scripting.Dictionary) + Set contents_ = oContents + Set sharedContents_ = oSharedCont +End Function + +Public Function ExportSrcTo(sPath$) + sourceHome_ = sPath + Call PrepareFolders(contents_) + Call InternalExport(contents_) +End Function + +Public Function ExportShared() + sourceHome_ = importsHome_ + Call PrepareFolders(sharedContents_) + Call InternalExport(sharedContents_) +End Function + +Public Function ImportSrcFrom(sPath$) + sourceHome_ = sPath + Call InternalImport(contents_) +End Function + +Public Function ImportShared() + sourceHome_ = importsHome_ + Call InternalImport(sharedContents_) +End Function + +Public Function RemoveAll() + Dim nItem&: nItem = 1 + Dim aComponent As VBIDE.VBComponent + Do While nItem <= proj_.VBComponents.Count + Set aComponent = proj_.VBComponents.Item(nItem) + If aComponent.Type <> vbext_ct_Document Then + If Not TryRemoving(aComponent) Then _ + nItem = nItem + 1 + Else + nItem = nItem + 1 + End If + Loop +End Function + +Public Function AddItem(sName$, sFolder$) + Call contents_.Add(sName, sFolder) +End Function + +Public Function AddSharedItem(sName$, sFolder$) + Call sharedContents_.Add(sName, sFolder) +End Function + +Public Function ReloadFrom(sFile$) As Boolean + ReloadFrom = False + If fso_.FileExists(sFile) Then _ + ReloadFrom = TryImportFile(fso_.GetFile(sFile)) +End Function + +' ========= +Private Function PrepareFolders(target As Scripting.Dictionary) + Call ProjEnsureFolderExists(sourceHome_) + + Dim sKey As Variant + For Each sKey In target + Call ProjEnsureFolderExists(sourceHome_ & "\" & CStr(target(sKey))) + Next sKey +End Function + +Private Function InternalExport(target As Scripting.Dictionary) + Dim fso As New Scripting.FileSystemObject + Dim aComponent As VBComponent + For Each aComponent In proj_.VBComponents + Dim sName$: sName = ComponentName(aComponent) + If Not target.Exists(sName) Then _ + GoTo NEXT_COMPONENT + + Dim sPath$: sPath = sourceHome_ & "\" & target(sName) & "\" & sName + If aComponent.Type = vbext_ct_MSForm Then _ + If HasNoChanges(aComponent, sPath) Then _ + GoTo NEXT_COMPONENT + Call aComponent.Export(sPath) +NEXT_COMPONENT: + Next aComponent +End Function + +Private Function InternalImport(tContents As Scripting.Dictionary) + Dim sFileName As Variant + Dim sPath$ + For Each sFileName In tContents + sPath = sourceHome_ & "\" & tContents(sFileName) & "\" & CStr(sFileName) + If fso_.FileExists(sPath) Then _ + Call TryImportFile(fso_.GetFile(sPath)) + Next sFileName +End Function + +Private Function TryImportFile(target As Scripting.File) As Boolean + TryImportFile = False + + Dim sExt$: sExt = fso_.GetExtensionName(target.Name) + Dim sName$: sName = fso_.GetBaseName(target.Name) + Dim sComp As VBIDE.VBComponent: Set sComp = ComponentByName(sName) + If Not sComp Is Nothing Then _ + If Not TryRemoving(sComp) Then _ + Exit Function + + Call proj_.VBComponents.Import(target.Path) + If sExt = "frm" Then _ + Call RemoveEmptyFirstLine(ComponentByName(sName).CodeModule) + + TryImportFile = True +End Function + +Private Function ComponentName(target As VBComponent) As String + ComponentName = target.Name + Select Case target.Type + Case vbext_ct_ClassModule: ComponentName = ComponentName & ".cls" + Case vbext_ct_MSForm: ComponentName = ComponentName & ".frm" + Case vbext_ct_StdModule: ComponentName = ComponentName & ".bas" + Case Else: ComponentName = vbNullString + End Select +End Function + +Private Function RemoveEmptyFirstLine(target As CodeModule) + Dim firstLineTxt$: firstLineTxt = target.Lines(1, 1) + If firstLineTxt = vbNullString Then _ + Call target.DeleteLines(1, 1) +End Function + +Private Function TryRemoving(target As VBIDE.VBComponent) As Boolean + Dim nCount& + nCount = proj_.VBComponents.Count + Call proj_.VBComponents.Remove(target) + TryRemoving = nCount <> proj_.VBComponents.Count +End Function + +Private Function ComponentByName(sName$) As VBIDE.VBComponent + Dim aComponent As VBComponent + For Each aComponent In proj_.VBComponents + If aComponent.Name = sName Then + Set ComponentByName = aComponent + Exit Function + End If + Next aComponent +End Function + +Private Function ProjEnsureFolderExists(sPath$) + If fso_.FolderExists(sPath) Then _ + Exit Function + + Dim sParent$: sParent = sPath + Do While VBA.Right(sParent, 1) = "\" + sParent = VBA.Left(sParent, VBA.Len(sParent) - 1) + Loop + sParent = VBA.Left(sParent, VBA.InStrRev(sParent, "\") - 1) + + Call ProjEnsureFolderExists(sParent) + Call fso_.CreateFolder(sPath) +End Function + +Private Function HasNoChanges(aForm As VBIDE.VBComponent, sPath$) As Boolean + HasNoChanges = False + + Dim fso As New Scripting.FileSystemObject + If Not fso.FileExists(sPath) Then _ + Exit Function + + Dim tmpDir$: tmpDir = fso.GetParentFolderName(sPath) & "\tmpFrm" + Dim tmpFile$: tmpFile = tmpDir & "\" & aForm.Name & ".frm" + Call fso.CreateFolder(tmpDir) + Call aForm.Export(tmpFile) + + Dim nFile1&: nFile1 = FreeFile + Open sPath For Input As #nFile1 + Dim cont1 As Variant: cont1 = Input(LOF(nFile1), nFile1) + Close nFile1 + + Dim nFile2&: nFile2 = FreeFile + Open tmpFile For Input As #nFile2 + Dim cont2 As Variant: cont2 = Input(LOF(nFile2), nFile2) + Close nFile2 + + HasNoChanges = cont1 = cont2 + Call fso.DeleteFolder(tmpDir) +End Function + diff --git a/api/API_Python.cls b/api/API_Python.cls new file mode 100644 index 0000000..d6c76fd --- /dev/null +++ b/api/API_Python.cls @@ -0,0 +1,221 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "API_Python" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'================ Python process object ========================= +' Shared module version: 20220713 +' Tested in: PythonManager +' Depends on: +' Required reference: +Option Explicit + +Private Const CONCEPT_DLL_LOCATION = "C:\Tools\dll" + +#If Win64 Then + Private Const PY_DLL_NAME As String = "vbatopy-connector64.dll" + + Private Declare PtrSafe Function StartPythonServer Lib "vbatopy-connector64.dll" ( _ + ByRef vResult As Variant, _ + ByVal sPython As String, _ + ByVal sModules As String, _ + ByVal bShowConsole As Long) As Long + + Private Declare PtrSafe Function KillPythonServer Lib "vbatopy-connector64.dll" Alias "KillServer" () As Long + Private Declare PtrSafe Function GetServer Lib "vbatopy-connector64.dll" (ByRef vResult As Variant) As Long +#Else + Private Const PY_DLL_NAME As String = "vbatopy-connector32.dll" + + Private Declare PtrSafe Function StartPythonServer Lib "vbatopy-connector32.dll" ( _ + ByRef vResult As Variant, _ + ByVal sPython As String, _ + ByVal sModules As String, _ + ByVal bShowConsole As Long) As Long + + Private Declare PtrSafe Function KillPythonServer Lib "vbatopy-connector32.dll" Alias "KillServer" () As Long + Private Declare PtrSafe Function GetServer Lib "vbatopy-connector32.dll" (ByRef vResult As Variant) As Long +#End If + +Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal sLibrary As String) As Long +Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal nLibraryHandle As Long) As Long + +Private python_ As Variant +Private pythonPath_ As String +Private modules_ As String +Private showConsole_ As Boolean + +Private Sub Class_Initialize() + Call ClearCahce +End Sub + +Private Sub Class_Terminate() + Call ClearCahce +End Sub + +Public Function ClearCahce() + Set python_ = Nothing +End Function + +' Initialize Python process +' iPython - path to python / python command +' sModules - path to python source code modules, delimiter = ';' +' bDoDebug - flag to show console output for python process +Public Function Init(iPython$, sModules$, Optional bDoDebug As Boolean = False) + Set python_ = Nothing + pythonPath_ = VBA.LCase(iPython) + pythonPath_ = VBA.Replace(pythonPath_, "program files (x86)", """program files (x86)""") + pythonPath_ = VBA.Replace(pythonPath_, "program files", """program files""") + pythonPath_ = VBA.Replace(pythonPath_, "\", "\\") + modules_ = sModules + showConsole_ = bDoDebug +End Function + +' Validate server is running +' If @python_ is not setup, then load current server dispatch into @python_ +Public Function Validate() As Boolean + Call LoadDLL + Call GetServer(python_) + Validate = Not python_ Is Nothing +End Function + +Public Function StartServer() + Call Validate + If Not python_ Is Nothing Then _ + Exit Function + + If StartPythonServer(python_, pythonPath_, modules_, IIf(showConsole_, 1, 0)) <> 0 Then _ + Call RaiseServerError + + If VBA.VarType(python_) = vbString Then + Call RaiseServerError + Set python_ = Nothing + End If +End Function + +Public Function KillServer() + Call Validate + If python_ Is Nothing Then _ + Exit Function + If KillPythonServer() <> 0 Then _ + Call RaiseServerError + Set python_ = Nothing +End Function + +' Preload Python module before using it - use if long setup is needed to load module +Public Function LoadModule(sFullPath$) As Boolean + On Error GoTo HANDLE_ERROR + LoadModule = Py.ImportModule(sFullPath) <> "" + On Error GoTo 0 + Exit Function + +HANDLE_ERROR: + Debug.Print Err.Description + LoadModule = False + On Error GoTo 0 +End Function + +' Run python command +Public Function Execute(sPyCommand$) As Boolean + On Error GoTo HANDLE_ERROR + Call Py.Exec("" & sPyCommand & "") + On Error GoTo 0 + Execute = True + Exit Function + +HANDLE_ERROR: + Debug.Print Err.Description + Execute = False + On Error GoTo 0 +End Function + +' Evaluate python statement +' Warning! Returns only basic types. Objects are not supported +Public Function Evaluate(sPyStatement$) As Variant + On Error GoTo HANDLE_ERROR + Evaluate = Py.Eval("" & sPyStatement & "") + On Error GoTo 0 + Exit Function + +HANDLE_ERROR: + Debug.Print Err.Description + Evaluate = Err.Description + On Error GoTo 0 +End Function + +' Call function from module. Arguments will be available from python including COM wrappers for any Office objects +' Warning! Returns basic types. To get objects from python use CallFunctionReturnObject +Public Function CallFunction(sModule$, sFunc$, Optional vArgs As Variant) As Variant + On Error GoTo HANDLE_ERROR + If IsMissing(vArgs) Then + CallFunction = Py.CallFunction(sModule, sFunc) + Else + CallFunction = Py.CallFunction(sModule, sFunc, vArgs) + End If + On Error GoTo 0 + Exit Function + +HANDLE_ERROR: + Debug.Print Err.Description + CallFunction = Err.Description +End Function + +Public Function CallFunctionReturnObject(sModule$, sFunc$, Optional vArgs As Variant) As Object + On Error GoTo HANDLE_ERROR + If IsMissing(vArgs) Then + Set CallFunctionReturnObject = Py.CallFunction(sModule, sFunc) + Else + Set CallFunctionReturnObject = Py.CallFunction(sModule, sFunc, vArgs) + End If + On Error GoTo 0 + Exit Function + +HANDLE_ERROR: + Debug.Print Err.Description + Set CallFunctionReturnObject = Nothing +End Function + +' Create VBA wrapper for target Python module in destination file path +Public Function WrapPython(sSourceModule$, sDestination$) As String + WrapPython = Py.WrapPython(sSourceModule, sDestination) +End Function + +' Preload @vbatopy DLL +' Note: Mostly usefull for testing setup because it allows using DLL calls without starting a server +Public Function LoadDLL() + If LoadLibrary(PY_DLL_NAME) <> 0 Then _ + Exit Function + If LoadLibrary(CONCEPT_DLL_LOCATION & "\" & PY_DLL_NAME) <> 0 Then _ + Exit Function + ' TODO: remove fallback after some time + ' fallback path for earlier versions of distribution + If LoadLibrary(VBA.Environ("USERPROFILE") & "\.concept\dll\" & PY_DLL_NAME) = 0 Then _ + Call Err.Raise(1, Description:="Could not load " & PY_DLL_NAME) +End Function + +' Unload DLL - need to call this before replacing dll file +Public Function UnloadDLL() + Dim nHandle&: nHandle = LoadLibrary(PY_DLL_NAME) + If nHandle <> 0 Then + Call KillServer + Call FreeLibrary(nHandle) + End If +End Function + +' ========= +Private Property Get Py() As Variant + If python_ Is Nothing Then _ + Call StartServer + Set Py = python_ +End Property + +Private Function RaiseServerError() + Dim sErr$: sErr = python_ + Set python_ = Nothing + Debug.Print sErr + Call Err.Raise(1000, Description:=sErr) +End Function + diff --git a/api/API_Ribbon.cls b/api/API_Ribbon.cls new file mode 100644 index 0000000..1b18eec --- /dev/null +++ b/api/API_Ribbon.cls @@ -0,0 +1,85 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "API_Ribbon" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'==== Оболочка для хранения и загрузки идентификатора ленты (Ribbon) ========================= +' Shared module version: 20210217 +' Required reference: Microsoft Scripting Runtime +Option Explicit + +Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, src As Any, ByVal nLen As Long) + +Private ribbon_ As IRibbonUI +Private backup_ As String + +Private Sub Class_Terminate() + If Not ribbon_ Is Nothing Then _ + Call KillBackup +End Sub + +Public Function Init(target As IRibbonUI, sBackup$) + Set ribbon_ = target + backup_ = sBackup + Call SaveBackup +End Function + +Public Property Get Value() As IRibbonUI + Set Value = ribbon_ +End Property + +Public Function LoadFrom(sFilePath$) As IRibbonUI + Set ribbon_ = Nothing + backup_ = sFilePath + + Call LoadBackup + + Set LoadFrom = ribbon_ +End Function + +' ======= +Private Function SaveBackup() + Dim ribbonPtr As LongPtr: ribbonPtr = ObjPtr(ribbon_) + Dim fso As New Scripting.FileSystemObject + Dim textOut As Scripting.TextStream: Set textOut = fso.CreateTextFile(backup_, Overwrite:=True) + If Not textOut Is Nothing Then + Call textOut.WriteLine(ribbonPtr) + Call textOut.Close + End If +End Function + +Private Function LoadBackup() + Dim fso As New Scripting.FileSystemObject + If Not fso.FileExists(backup_) Then _ + Exit Function + + Dim textIn As Scripting.TextStream: Set textIn = fso.OpenTextFile(backup_) + If textIn Is Nothing Then _ + Exit Function + + Dim ptrSize& + #If Win64 Then + ptrSize = 8 + #Else + ptrSize = 4 + #End If + + Dim aLine$: aLine = textIn.ReadLine + If IsNumeric(aLine) Then + Dim nPtr As LongPtr: nPtr = CLngPtr(aLine) + Dim objRibbon As Object + Call CopyMemory(objRibbon, nPtr, ptrSize) + Set ribbon_ = objRibbon + Call CopyMemory(objRibbon, 0&, ptrSize) + End If +End Function + +Private Function KillBackup() + Dim fso As New Scripting.FileSystemObject + If fso.FileExists(backup_) Then _ + Call fso.DeleteFile(backup_) +End Function diff --git a/api/API_UserInteraction.cls b/api/API_UserInteraction.cls new file mode 100644 index 0000000..e8a02d3 --- /dev/null +++ b/api/API_UserInteraction.cls @@ -0,0 +1,121 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "API_UserInteraction" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'================ Класс инкапсуляции взаимодействия с пользователем ========================= +' Shared module version: 20220611 +' Depends on: +' Required reference: +Option Explicit + +Public Function ShowMessage(nMsg&, ParamArray params() As Variant) + Call UIShowMessage(nMsg, params) +End Function + +Public Function AskQuestion(nQuestion&, ParamArray params() As Variant) As Boolean + AskQuestion = UIAskQuestion(nQuestion, params) +End Function + +Public Function FollowHyperlink(oDocument As Object, sAddress$) + Call oDocument.FollowHyperlink(sAddress) +End Function + +Public Function PromptInput(sPrompt$, Optional sTitle$ = vbNullString, Optional sInitial As Variant) As String + PromptInput = VBA.InputBox(sPrompt, sTitle, sInitial) +End Function + +Public Function PromptFileFilter(sInitialPath$, sDescription$, sFilter$, _ + Optional sTitle$ = "Выберите файл", _ + Optional bNewApplication As Boolean = False) As String + Dim cFilters As New Collection + Dim cDescriptions As New Collection + + Call cFilters.Add("*.*") + Call cDescriptions.Add("Все файлы") + Call cFilters.Add(sFilter) + Call cDescriptions.Add(sDescription) + + PromptFileFilter = PromptFile(sInitialPath, sTitle, cDescriptions, cFilters, bNewApplication) +End Function + +Public Function PromptFile(sInitialPath$, _ + Optional sTitle$ = "Выберите файл", _ + Optional cDescriptions As Collection = Nothing, _ + Optional cFilters As Collection = Nothing, _ + Optional bNewApplication As Boolean = False) As String + PromptFile = vbNullString + Dim oApplication As Object + If Not bNewApplication Then + Set oApplication = Application + Else + Set oApplication = CreateObject("Excel.Application") + oApplication.Visible = True + End If + + Dim filterCount&: filterCount = 0 + If Not cDescriptions Is Nothing And Not cFilters Is Nothing Then _ + If cDescriptions.Count = cFilters.Count Then _ + filterCount = cFilters.Count + + On Error Resume Next + + With oApplication.FileDialog(msoFileDialogFilePicker) + .InitialFileName = sInitialPath + .AllowMultiSelect = False + .ButtonName = "Выбрать" + .Title = sTitle + + Call .Filters.Clear + If filterCount > 0 Then + + Dim nItem& + For nItem = 1 To filterCount Step 1 + Call .Filters.Add(cDescriptions.Item(nItem), cFilters.Item(nItem), 1) + Next nItem + Else + Call .Filters.Add("Все файлы", "*.*") + End If + + Call .Show + If .SelectedItems.Count > 0 Then _ + PromptFile = .SelectedItems(1) + End With + + If bNewApplication Then _ + Call oApplication.Quit +End Function + +Public Function PromptFolder(sInitialPath$, _ + Optional sTitle$ = "Выберите каталог", _ + Optional bNewApplication As Boolean = False) As String + PromptFolder = vbNullString + Dim oApplication As Object + If Not bNewApplication Then + Set oApplication = Application + Else + Set oApplication = CreateObject("Excel.Application") + oApplication.Visible = True + End If + + On Error Resume Next + With oApplication.FileDialog(msoFileDialogFolderPicker) + .InitialFileName = sInitialPath + .AllowMultiSelect = False + .ButtonName = "Выбрать" + .Title = sTitle + + Call .Show + + If .SelectedItems.Count > 0 Then _ + PromptFolder = .SelectedItems(1) + End With + + If bNewApplication Then _ + Call oApplication.Quit +End Function + diff --git a/api/API_VsoWrapper.cls b/api/API_VsoWrapper.cls new file mode 100644 index 0000000..a75160a --- /dev/null +++ b/api/API_VsoWrapper.cls @@ -0,0 +1,376 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "API_VsoWrapper" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ================ Класс-оболочка для документа MS Visio ========================= +' Shared module version: 20220410 +' Tested in: TestCommons +' Depends on: +' Required reference: Scripting, Visio +Option Explicit + +Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal nHwnd As Long, nProcID As Long) As Long + +Private application_ As Visio.Application +Private document_ As Visio.Document +Private reporter_ As Object +Private bSilent_ As Boolean + +Private deferRel_ As Boolean +Private deferRecalc_ As Boolean +Private isPaused_ As Boolean + +Private bCloseOnFail_ As Boolean +Private bOwnsDoc_ As Boolean +Private bOwnsApp_ As Boolean + +Private Sub Class_Initialize() + Call ResetAll +End Sub + +Private Sub Class_Terminate() + If application_ Is Nothing Then _ + Exit Sub + ' Note: application could be owned by another Wrapper and already quit + On Error GoTo SKIP_RELEASE + If application_.Documents.Count = 0 Then _ + Call ReleaseApplication +SKIP_RELEASE: +End Sub + +Public Function ResetAll() + Call ResetDocument + + deferRel_ = False + deferRecalc_ = False + bSilent_ = False +End Function + +Public Function ResetDocument() + Set application_ = Nothing + Set document_ = Nothing + bOwnsDoc_ = False + bOwnsApp_ = False + bCloseOnFail_ = False + isPaused_ = False +End Function + +' Reporter object should implement callback function Report(sMsg$, nFlags&) +Public Function SetReporter(aReporter As Object) + Set reporter_ = aReporter +End Function + +Public Property Get Document() As Visio.Document + Set Document = document_ +End Property + +Public Property Get Application() As Visio.Application + Set Application = application_ +End Property + +Public Property Get IsUIPaused() As Boolean + IsUIPaused = isPaused_ +End Property + +Public Function DisableMessages() + bSilent_ = True +End Function + +Public Function EnableMessages() + bSilent_ = False +End Function + +Public Function CreateApplication(Optional bIsVisible As Boolean = True) As Visio.Application + Call ResetDocument + Set application_ = CreateObject("Visio.Application") + bOwnsApp_ = True + application_.Visible = bIsVisible + Set CreateApplication = application_ +End Function + +Public Function SetApplication(target As Visio.Application) + If ObjPtr(application_) = ObjPtr(target) Then _ + Exit Function + Call ResetDocument + Set application_ = target +End Function + +Public Function SetDocument(target As Visio.Document, Optional bOwnership = False) + If ObjPtr(target) = ObjPtr(document_) Then + bOwnsDoc_ = bOwnership + Exit Function + End If + If Not target Is Nothing Then _ + Call SetApplication(target.Application) + bOwnsDoc_ = bOwnership + Set document_ = target +End Function + +Public Function PauseUI() + If application_ Is Nothing Then _ + Exit Function + If document_ Is Nothing Then _ + Exit Function + + Debug.Assert Not isPaused_ + isPaused_ = True + deferRel_ = application_.DeferRelationshipRecalc + deferRecalc_ = application_.DeferRecalc + application_.ScreenUpdating = False + application_.DeferRecalc = True + application_.DeferRelationshipRecalc = True +End Function + +Public Function ResumeUI() + If application_ Is Nothing Then _ + Exit Function + If document_ Is Nothing Then _ + Exit Function + + isPaused_ = False + application_.DeferRelationshipRecalc = deferRel_ + application_.DeferRecalc = deferRecalc_ + application_.ScreenUpdating = True +End Function + +Public Function Run(sFunc$, ParamArray vArgs() As Variant) + ' Note: running code in Visio cannot return value, so use file IO instead if needed (pass output filename through args) + Dim nArgCount&: nArgCount = UBound(vArgs) - LBound(vArgs) + 1 + Dim sCommand$: sCommand = "Call " & sFunc & "(" + Dim nArg& + For nArg = 0 To nArgCount - 1 Step 1 + If nArg <> 0 Then _ + sCommand = sCommand & ", " + sCommand = sCommand & """" & CStr(vArgs(nArg)) & """" + Next nArg + sCommand = sCommand & ")" + Call Document.ExecuteLine(sCommand) +End Function + +Public Function NewDocument(Optional sTemplate$ = vbNullString, _ + Optional bDefaultIfFail As Boolean = True) As Visio.Document + If Not document_ Is Nothing Then _ + Exit Function + + If application_ Is Nothing Then + bCloseOnFail_ = True + Call CreateApplication + End If + + On Error GoTo TRY_DEFAULT + + Set document_ = application_.Documents.Add(sTemplate) + bOwnsDoc_ = True + Set NewDocument = document_ + + Exit Function + +TRY_DEFAULT: + If sTemplate <> vbNullString Then + Call Report("Не удалось создать документ из шаблона " & sTemplate) + If Not bDefaultIfFail Then + If bCloseOnFail_ Then _ + Call ReleaseApplication + Else + On Error GoTo ERR_DEFAULT + Set document_ = application_.Documents.Add("") + Set NewDocument = document_ + End If + Exit Function + End If + +ERR_DEFAULT: + Call Report("Не удалось создать новый документ из базового шаблона") + If bCloseOnFail_ Then _ + Call ReleaseApplication +End Function + +Public Function OpenDocument(sFile$, Optional nOpenFlags As Integer = 0) As Visio.Document +' Note: Документы Visio не поддерживают опцию ReadOnly + If Not document_ Is Nothing Then _ + Exit Function + + Dim bResetApplication As Boolean + bResetApplication = application_ Is Nothing + If bResetApplication Then _ + Call DefaultApplication + + If TryAlreadyOpened(sFile) Then + Set OpenDocument = document_ + Exit Function + End If + + If Not TestFile(sFile) Then _ + GoTo SAFE_EXIT + + On Error GoTo SAFE_EXIT + Set document_ = application_.Documents.OpenEx(sFile, nOpenFlags) + On Error GoTo 0 + + If Not document_ Is Nothing Then + bOwnsDoc_ = True + Set OpenDocument = document_ + Else +SAFE_EXIT: + bOwnsDoc_ = False + If bCloseOnFail_ Then _ + Call KillApplication + If bResetApplication Then _ + Set application_ = Nothing + End If +End Function + +Public Function ReleaseApplication() + If bOwnsApp_ Then _ + Call KillApplication + Call ResetDocument +End Function + +Public Function ReleaseDocument(Optional bCloseApplication As Boolean = True, _ + Optional bSaveChanges As Boolean = False) As Boolean + ReleaseDocument = False + If document_ Is Nothing Then _ + Exit Function + If Not bOwnsDoc_ Then + Set document_ = Nothing + ReleaseDocument = True + Exit Function + End If + + On Error GoTo EXIT_FUNC + + If (bSaveChanges And document_.Path <> vbNullString) Then + Call document_.OpenStencilWindow + Call document_.Save + End If + + Dim nInitialResponse&: nInitialResponse = application_.AlertResponse + application_.AlertResponse = vbNo + Call document_.Close + application_.AlertResponse = nInitialResponse + + On Error GoTo 0 + + Set document_ = Nothing + ReleaseDocument = True + If bCloseApplication And application_.Documents.Count = 0 Then _ + Call ReleaseApplication +EXIT_FUNC: +End Function + +Public Function SaveAs(sTargetName$) As Boolean + SaveAs = False + + If document_ Is Nothing Then _ + Exit Function + + On Error GoTo RETURN_FALSE + Call document_.SaveAs(sTargetName) + On Error GoTo 0 + + SaveAs = True + Exit Function +RETURN_FALSE: +End Function + +' =========== +Private Function Report(sMsg$) + If bSilent_ Then + Debug.Print "VisioWrapper: " & sMsg + Exit Function + ElseIf reporter_ Is Nothing Then + Call MsgBox(sMsg, vbExclamation) + Else + Call reporter_.Report(sMsg, vbExclamation) + End If +End Function + +Private Function DefaultApplication() + bOwnsApp_ = False + On Error GoTo CREATE_NEW_APPL + Set application_ = GetObject(, "Visio.Application") + On Error GoTo 0 + Exit Function + +CREATE_NEW_APPL: + Set application_ = CreateObject("Visio.Application") + bOwnsApp_ = True + bCloseOnFail_ = True + application_.Visible = True +End Function + +Private Function KillApplication() + Const HIDE_SHELL = 0 + Const WAIT_RETURN = True + + On Error GoTo OFFICE_QUIT + + Dim nThreadID&, nProcID& + nThreadID = GetWindowThreadProcessId(application_.WindowHandle32, nProcID) + + Dim iShell As Object: Set iShell = VBA.CreateObject("WScript.Shell") + If iShell.Run("TaskKill /F /PID " & nProcID, HIDE_SHELL, WAIT_RETURN) = 0 Then _ + Exit Function + +OFFICE_QUIT: + Call application_.Quit +End Function + +Private Function TryAlreadyOpened(sFile$) As Boolean + TryAlreadyOpened = False + + Set document_ = FindByName(sFile) + If document_ Is Nothing Then _ + Exit Function + + bOwnsDoc_ = False + TryAlreadyOpened = True +End Function + +Private Function TestFile(sFile$) As Boolean + Const ATTRIBUTE_READONLY = 1 + TestFile = False + + Dim fso As New Scripting.FileSystemObject + If Not fso.FileExists(sFile) Then + Call Report("Файл не найден: " & sFile) + Exit Function + End If + + If fso.GetFile(sFile).Attributes And ATTRIBUTE_READONLY Then + Call Report("Файл ReadOnly: " & sFile) + Exit Function + End If + If IsFileInUse(sFile) Then + Call Report("Файл заблокирован: " & sFile) + Exit Function + End If + + TestFile = True +End Function + +Private Function FindByName(sName$) As Visio.Document + Dim aDoc As Visio.Document + For Each aDoc In application_.Documents + If aDoc.FullName = sName Then + Set FindByName = aDoc + Exit Function + End If + Next aDoc +End Function + +Private Function IsFileInUse(sFileName$) As Boolean + Dim nFile%: nFile = FreeFile + On Error Resume Next + + Open sFileName For Binary Access Read Lock Read Write As #nFile + Close #nFile + IsFileInUse = Err.Number > 0 + + On Error GoTo 0 +End Function diff --git a/api/API_WordWrapper.cls b/api/API_WordWrapper.cls new file mode 100644 index 0000000..3c7e4e4 --- /dev/null +++ b/api/API_WordWrapper.cls @@ -0,0 +1,394 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "API_WordWrapper" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ================ Класс-оболочка для документа MS Word ========================= +' Shared module version: 20220410 +' Tested in: TestCommons +' Depends on: +' Required reference: Scripting, Word +Option Explicit + +Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal nHwnd As Long, nProcID As Long) As Long + +Private application_ As Word.Application +Private document_ As Word.Document +Private reporter_ As Object +Private bSilent_ As Boolean + +Private isPaused_ As Boolean +Private screenUpdate_ As Boolean +Private proofing_ As Boolean + +Private bCloseOnFail_ As Boolean +Private bOwnsDoc_ As Boolean +Private bOwnsApp_ As Boolean + +Private Sub Class_Initialize() + Call ResetAll +End Sub + +Private Sub Class_Terminate() + If application_ Is Nothing Then _ + Exit Sub + ' Note: application could be owned by another Wrapper and already quit + On Error GoTo SKIP_RELEASE + If application_.Documents.Count = 0 Then _ + Call ReleaseApplication +SKIP_RELEASE: +End Sub + +Public Function ResetAll() + Call ResetDocument + + screenUpdate_ = True + proofing_ = True + bSilent_ = False +End Function + +Public Function ResetDocument() + Set application_ = Nothing + Set document_ = Nothing + bOwnsDoc_ = False + bOwnsApp_ = False + bCloseOnFail_ = False + isPaused_ = False +End Function + +' Reporter object should implement callback function Report(sMsg$, nFlags&) +Public Function SetReporter(aReporter As Object) + Set reporter_ = aReporter +End Function + +Public Property Get Document() As Word.Document + Set Document = document_ +End Property + +Public Property Get Application() As Word.Application + Set Application = application_ +End Property + +Public Property Get IsUIPaused() As Boolean + IsUIPaused = isPaused_ +End Property + +Public Function DisableMessages() + bSilent_ = True +End Function + +Public Function EnableMessages() + bSilent_ = False +End Function + +Public Function CreateApplication(Optional bIsVisible As Boolean = True) As Word.Application + Call ResetDocument + Set application_ = CreateObject("Word.Application") + bOwnsApp_ = True + application_.Visible = bIsVisible + Set CreateApplication = application_ +End Function + +Public Function SetApplication(target As Word.Application) + If ObjPtr(application_) = ObjPtr(target) Then _ + Exit Function + Call ResetDocument + Set application_ = target +End Function + +Public Function SetDocument(target As Word.Document, Optional bOwnership = False) + If ObjPtr(target) = ObjPtr(document_) Then + bOwnsDoc_ = bOwnership + Exit Function + End If + If Not target Is Nothing Then _ + Call SetApplication(target.Application) + bOwnsDoc_ = bOwnership + Set document_ = target +End Function + +Public Function PauseUI() + If application_ Is Nothing Then _ + Exit Function + If document_ Is Nothing Then _ + Exit Function + + Debug.Assert Not isPaused_ + isPaused_ = True + screenUpdate_ = application_.ScreenUpdating + proofing_ = document_.Range.NoProofing + application_.ScreenUpdating = False + document_.Range.NoProofing = True +End Function + +Public Function ResumeUI() + If application_ Is Nothing Then _ + Exit Function + If document_ Is Nothing Then _ + Exit Function + + isPaused_ = False + application_.ScreenUpdating = screenUpdate_ + document_.Range.NoProofing = proofing_ + Call application_.ScreenRefresh +End Function + +Public Function Run(sCommand$, ParamArray vArgs() As Variant) As Variant + Dim nArgCount&: nArgCount = UBound(vArgs) - LBound(vArgs) + 1 + Select Case nArgCount + Case 0: Run = application_.Run(sCommand) + Case 1: Run = application_.Run(sCommand, vArgs(0)) + Case 2: Run = application_.Run(sCommand, vArgs(0), vArgs(1)) + Case 3: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2)) + Case 4: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2), vArgs(3)) + Case 5: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4)) + Case 6: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5)) + Case 7: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6)) + End Select +End Function + +Public Function NewDocument(Optional sTemplate$ = vbNullString, _ + Optional bDefaultIfFail As Boolean = True) As Word.Document + If Not document_ Is Nothing Then _ + Exit Function + + If application_ Is Nothing Then + bCloseOnFail_ = True + Call CreateApplication + End If + + On Error GoTo TRY_DEFAULT + + Set document_ = application_.Documents.Add(sTemplate) + bOwnsDoc_ = True + Set NewDocument = document_ + + Exit Function + +TRY_DEFAULT: + If sTemplate <> vbNullString Then + Call Report("Не удалось создать документ из шаблона " & sTemplate) + If Not bDefaultIfFail Then + If bCloseOnFail_ Then _ + Call ReleaseApplication + Else + On Error GoTo ERR_DEFAULT + Set document_ = application_.Documents.Add + Set NewDocument = document_ + End If + Exit Function + End If + +ERR_DEFAULT: + Call Report("Не удалось создать новый документ из базового шаблона") + If bCloseOnFail_ Then _ + Call ReleaseApplication +End Function + +Public Function OpenDocument(sFile$, _ + Optional bReadOnly As Boolean = False, _ + Optional bTrackMRU As Boolean = False) As Word.Document + If Not document_ Is Nothing Then _ + Exit Function + + Dim bResetApplication As Boolean + bResetApplication = application_ Is Nothing + If bResetApplication Then _ + Call DefaultApplication + + If TryAlreadyOpened(sFile, bReadOnly) Then + Set OpenDocument = document_ + Exit Function + End If + + If Not TestFile(sFile, bReadOnly) Then _ + GoTo SAFE_EXIT + + On Error GoTo SAFE_EXIT + Set document_ = application_.Documents.Open(sFile, AddToRecentFiles:=bTrackMRU, ReadOnly:=bReadOnly) + On Error GoTo 0 + + If Not document_ Is Nothing Then + bOwnsDoc_ = True + Set OpenDocument = document_ + Else +SAFE_EXIT: + bOwnsDoc_ = False + If bCloseOnFail_ Then _ + Call KillApplication + If bResetApplication Then _ + Set application_ = Nothing + End If +End Function + +Public Function ReleaseApplication() + If bOwnsApp_ Then _ + Call KillApplication + Call ResetDocument +End Function + +Public Function ReleaseDocument(Optional bCloseApplication As Boolean = True, _ + Optional bSaveChanges As Boolean = False) As Boolean + ReleaseDocument = False + If document_ Is Nothing Then _ + Exit Function + If Not bOwnsDoc_ Then + Set document_ = Nothing + ReleaseDocument = True + Exit Function + End If + + On Error GoTo EXIT_FUNC + Call document_.Close(SaveChanges:=(bSaveChanges And document_.Path <> vbNullString)) + On Error GoTo 0 + + Set document_ = Nothing + ReleaseDocument = True + If (bCloseApplication And application_.Documents.Count = 0) Then _ + Call ReleaseApplication +EXIT_FUNC: +End Function + +Public Function SaveAs(sTargetName$) As Boolean + SaveAs = False + + If document_ Is Nothing Then _ + Exit Function + + On Error GoTo RETURN_FALSE + + Dim fso As New Scripting.FileSystemObject + Dim nFormat As WdSaveFormat + If GetSaveFormat(fso.GetExtensionName(sTargetName), nFormat) Then + Call document_.SaveAs2(sTargetName, FileFormat:=nFormat) + Else + Call document_.SaveAs2(sTargetName) + End If + + On Error GoTo 0 + + SaveAs = True + Exit Function +RETURN_FALSE: +End Function + +' ======= +Private Function Report(sMsg$) + If bSilent_ Then + Debug.Print "WordWrapper: " & sMsg + Exit Function + ElseIf reporter_ Is Nothing Then + Call MsgBox(sMsg, vbExclamation) + Else + Call reporter_.Report(sMsg, vbExclamation) + End If +End Function + +Private Function DefaultApplication() + bOwnsApp_ = False + On Error GoTo CREATE_NEW_APPL + Set application_ = GetObject(, "Word.Application") + On Error GoTo 0 + Exit Function + +CREATE_NEW_APPL: + Set application_ = CreateObject("Word.Application") + bOwnsApp_ = True + bCloseOnFail_ = True + application_.Visible = True +End Function + +Private Function KillApplication() + Const HIDE_SHELL = 0 + Const WAIT_RETURN = True + + On Error GoTo OFFICE_QUIT + + Dim nThreadID&, nProcID& + Call application_.Documents.Add ' Create new document for ActiveWindow to become available + nThreadID = GetWindowThreadProcessId(application_.ActiveWindow.Hwnd, nProcID) + + Dim iShell As Object: Set iShell = VBA.CreateObject("WScript.Shell") + If iShell.Run("TaskKill /F /PID " & nProcID, HIDE_SHELL, WAIT_RETURN) = 0 Then _ + Exit Function + +OFFICE_QUIT: + Call application_.Quit(SaveChanges:=False) +End Function + +Private Function TryAlreadyOpened(sFile$, bReadOnly As Boolean) As Boolean + TryAlreadyOpened = False + + Set document_ = FindByName(sFile) + If document_ Is Nothing Then _ + Exit Function + If document_.ReadOnly And Not bReadOnly Then + Set document_ = Nothing + Exit Function + End If + + bOwnsDoc_ = False + TryAlreadyOpened = True +End Function + +Private Function TestFile(sFile$, bReadOnly As Boolean) As Boolean + Const ATTRIBUTE_READONLY = 1 + TestFile = False + + Dim fso As New Scripting.FileSystemObject + If Not fso.FileExists(sFile) Then + Call Report("Файл не найден: " & sFile) + Exit Function + End If + + If Not bReadOnly Then + If fso.GetFile(sFile).Attributes And ATTRIBUTE_READONLY Then + Call Report("Файл ReadOnly: " & sFile) + Exit Function + End If + If IsFileInUse(sFile) Then + Call Report("Файл заблокирован: " & sFile) + Exit Function + End If + End If + + TestFile = True +End Function + +Private Function FindByName(sName$) As Word.Document + Dim aDoc As Word.Document + For Each aDoc In application_.Documents + If aDoc.FullName = sName Then + Set FindByName = aDoc + Exit Function + End If + Next aDoc +End Function + +Private Function IsFileInUse(sFileName$) As Boolean + Dim nFile%: nFile = FreeFile + On Error Resume Next + + Open sFileName For Binary Access Read Lock Read Write As #nFile + Close #nFile + IsFileInUse = Err.Number > 0 + + On Error GoTo 0 +End Function + +Private Function GetSaveFormat(sExtension$, ByRef nFormat As WdSaveFormat) As Boolean + GetSaveFormat = True + Select Case VBA.UCase(sExtension) + Case "DOCX": nFormat = wdFormatXMLDocument + Case "DOCM": nFormat = wdFormatXMLDocumentMacroEnabled + Case "DOTX": nFormat = wdFormatXMLTemplate + Case "DOTM": nFormat = wdFormatXMLTemplateMacroEnabled + Case "TXT": nFormat = wdFormatText + Case "PDF": nFormat = wdFormatPDF + Case Else: GetSaveFormat = False + End Select +End Function diff --git a/api/API_XLWrapper.cls b/api/API_XLWrapper.cls new file mode 100644 index 0000000..37ade8a --- /dev/null +++ b/api/API_XLWrapper.cls @@ -0,0 +1,412 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "API_XLWrapper" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ================ Класс-оболочка для документа MS Excel ========================= +' Shared module version: 20220421 +' Tested in: TestCommons +' Depends on: +' Required reference: Scripting, Excel +Option Explicit + +Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal nHwnd As Long, nProcID As Long) As Long + +Private application_ As Excel.Application +Private document_ As Excel.Workbook +Private reporter_ As Object +Private bSilent_ As Boolean + +Private isPaused_ As Boolean +Private calculation_ As Excel.XlCalculation + +Private bCloseOnFail_ As Boolean +Private bOwnsDoc_ As Boolean +Private bOwnsApp_ As Boolean + +Private Sub Class_Initialize() + Call ResetAll +End Sub + +Private Sub Class_Terminate() + If application_ Is Nothing Then _ + Exit Sub + ' Note: application could be owned by another Wrapper and already quit + On Error GoTo SKIP_RELEASE + If application_.Workbooks.Count = 0 Then _ + Call ReleaseApplication +SKIP_RELEASE: +End Sub + +Public Function ResetAll() + Call ResetDocument + + calculation_ = xlCalculationAutomatic + bSilent_ = False +End Function + +Public Function ResetDocument() + Set application_ = Nothing + Set document_ = Nothing + bOwnsDoc_ = False + bOwnsApp_ = False + bCloseOnFail_ = False + isPaused_ = False +End Function + +' Reporter object should implement callback function Report(sMsg$, nFlags&) +Public Function SetReporter(aReporter As Object) + Set reporter_ = aReporter +End Function + +Public Property Get Document() As Excel.Workbook + Set Document = document_ +End Property + +Public Property Get Application() As Excel.Application + Set Application = application_ +End Property + +Public Property Get IsUIPaused() As Boolean + IsUIPaused = isPaused_ +End Property + +Public Function DisableMessages() + bSilent_ = True +End Function + +Public Function EnableMessages() + bSilent_ = False +End Function + +Public Function CreateApplication(Optional bIsVisible As Boolean = True) As Excel.Application + Call ResetDocument + Set application_ = CreateObject("Excel.Application") + bOwnsApp_ = True + application_.Visible = bIsVisible + Set CreateApplication = application_ +End Function + +Public Function SetApplication(target As Excel.Application) + If ObjPtr(application_) = ObjPtr(target) Then _ + Exit Function + Call ResetDocument + Set application_ = target +End Function + +Public Function SetDocument(target As Excel.Workbook, Optional bOwnership = False) + If ObjPtr(target) = ObjPtr(document_) Then + bOwnsDoc_ = bOwnership + Exit Function + End If + If Not target Is Nothing Then _ + Call SetApplication(target.Application) + bOwnsDoc_ = bOwnership + Set document_ = target +End Function + +Public Function PauseUI() + If application_ Is Nothing Then _ + Exit Function + If document_ Is Nothing Then _ + Exit Function + + Debug.Assert Not isPaused_ + isPaused_ = True + calculation_ = application_.Calculation + application_.Calculation = xlCalculationManual + application_.ScreenUpdating = False + application_.EnableEvents = False + application_.AskToUpdateLinks = False + application_.Cursor = xlWait +End Function + +Public Function ResumeUI() + If application_ Is Nothing Then _ + Exit Function + If document_ Is Nothing Then _ + Exit Function + + isPaused_ = False + application_.Cursor = xlNormal + application_.AskToUpdateLinks = True + application_.EnableEvents = True + application_.ScreenUpdating = True + application_.Calculation = calculation_ +End Function + +Public Function Run(sFunction$, ParamArray vArgs() As Variant) As Variant + Dim sCommand$: sCommand = "'" & document_.Name & "'" & "!" & sFunction + Dim nArgCount&: nArgCount = UBound(vArgs) - LBound(vArgs) + 1 + Select Case nArgCount + Case 0: Run = application_.Run(sCommand) + Case 1: Run = application_.Run(sCommand, vArgs(0)) + Case 2: Run = application_.Run(sCommand, vArgs(0), vArgs(1)) + Case 3: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2)) + Case 4: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2), vArgs(3)) + Case 5: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4)) + Case 6: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5)) + Case 7: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6)) + End Select +End Function + +Public Function NewDocument(Optional sTemplate$ = vbNullString, _ + Optional bDefaultIfFail As Boolean = True) As Excel.Workbook + If Not document_ Is Nothing Then _ + Exit Function + If application_ Is Nothing Then + bCloseOnFail_ = True + Call CreateApplication + End If + + On Error GoTo TRY_DEFAULT + + Set document_ = application_.Workbooks.Add(sTemplate) + bOwnsDoc_ = True + Set NewDocument = document_ + + Exit Function + +TRY_DEFAULT: + If sTemplate <> vbNullString Then + Call Report("Не удалось создать документ из шаблона " & sTemplate) + If Not bDefaultIfFail Then + If bCloseOnFail_ Then _ + Call ReleaseApplication + Else + On Error GoTo ERR_DEFAULT + Set document_ = application_.Workbooks.Add + Set NewDocument = document_ + End If + Exit Function + End If + +ERR_DEFAULT: + Call Report("Не удалось создать новый документ из базового шаблона") + If bCloseOnFail_ Then _ + Call ReleaseApplication +End Function + +Public Function OpenDocument(sFile$, _ + Optional bReadOnly As Boolean = False, _ + Optional bTrackMRU As Boolean = False, _ + Optional bIgnoreFolder As Boolean = False) As Excel.Workbook + If Not document_ Is Nothing Then _ + Exit Function + + Dim bResetApplication As Boolean + bResetApplication = application_ Is Nothing + If bResetApplication Then _ + Call DefaultApplication + + If TryAlreadyOpened(sFile, bReadOnly, bIgnoreFolder) Then + Set OpenDocument = document_ + Exit Function + End If + + If Not TestFile(sFile, bReadOnly, bIgnoreFolder) Then _ + GoTo SAFE_EXIT + + On Error GoTo SAFE_EXIT + If sFile Like "*.csv" Then + Set document_ = application_.Workbooks.Open(sFile, addToMRU:=bTrackMRU, ReadOnly:=bReadOnly, Editable:=True, Format:=6, Delimiter:=",") + Else + Set document_ = application_.Workbooks.Open(sFile, addToMRU:=bTrackMRU, ReadOnly:=bReadOnly, Editable:=True) + End If + On Error GoTo 0 + + If Not document_ Is Nothing Then + bOwnsDoc_ = True + Set OpenDocument = document_ + Else +SAFE_EXIT: + bOwnsDoc_ = False + If bCloseOnFail_ Then _ + Call KillApplication + If bResetApplication Then _ + Set application_ = Nothing + End If +End Function + +Public Function ReleaseApplication() + If bOwnsApp_ Then _ + Call KillApplication + Call ResetDocument +End Function + +Public Function ReleaseDocument(Optional bCloseApplication As Boolean = True, _ + Optional bSaveChanges As Boolean = False) As Boolean + ReleaseDocument = False + If document_ Is Nothing Then _ + Exit Function + If Not bOwnsDoc_ Then + Set document_ = Nothing + ReleaseDocument = True + Exit Function + End If + + On Error GoTo EXIT_FUNC + Call document_.Close(SaveChanges:=(bSaveChanges And document_.Path <> vbNullString)) + On Error GoTo 0 + + Set document_ = Nothing + ReleaseDocument = True + If bCloseApplication And application_.Workbooks.Count = 0 Then _ + Call ReleaseApplication +EXIT_FUNC: +End Function + +Public Function SaveAs(sTargetName$) As Boolean + SaveAs = False + + If document_ Is Nothing Then _ + Exit Function + + Dim bDisplayAlerts As Boolean: bDisplayAlerts = application_.DisplayAlerts + application_.DisplayAlerts = False + + On Error GoTo RETURN_FALSE + + Dim fso As New Scripting.FileSystemObject + Dim nFormat As Excel.XlFileFormat + If GetSaveFormat(fso.GetExtensionName(sTargetName), nFormat) Then + Call document_.SaveAs(sTargetName, FileFormat:=nFormat, ConflictResolution:=xlLocalSessionChanges) + Else + Call document_.SaveAs(sTargetName, ConflictResolution:=xlLocalSessionChanges) + End If + + On Error GoTo 0 + + application_.DisplayAlerts = bDisplayAlerts + SaveAs = True + Exit Function + +RETURN_FALSE: + application_.DisplayAlerts = bDisplayAlerts +End Function + +' ======== +Private Function Report(sMsg$) + If bSilent_ Then + Debug.Print "XLWrapper: " & sMsg + Exit Function + ElseIf reporter_ Is Nothing Then + Call MsgBox(sMsg, vbExclamation) + Else + Call reporter_.Report(sMsg, vbExclamation) + End If +End Function + +Private Function DefaultApplication() + bOwnsApp_ = False + On Error GoTo CREATE_NEW_APPL + Set application_ = GetObject(, "Excel.Application") + On Error GoTo 0 + Exit Function + +CREATE_NEW_APPL: + Set application_ = CreateObject("Excel.Application") + bOwnsApp_ = True + bCloseOnFail_ = True + application_.Visible = True +End Function + +Private Function KillApplication() + Const HIDE_SHELL = 0 + Const WAIT_RETURN = True + + On Error GoTo OFFICE_QUIT + + Dim nThreadID&, nProcID& + nThreadID = GetWindowThreadProcessId(application_.Hwnd, nProcID) + + Dim iShell As Object: Set iShell = VBA.CreateObject("WScript.Shell") + If iShell.Run("TaskKill /F /PID " & nProcID, HIDE_SHELL, WAIT_RETURN) = 0 Then _ + Exit Function + +OFFICE_QUIT: + Call application_.Quit +End Function + +Private Function TryAlreadyOpened(sFile$, bReadOnly As Boolean, bIgnoreFolder As Boolean) As Boolean + TryAlreadyOpened = False + + Dim fso As New Scripting.FileSystemObject + Set document_ = FindByName(IIf(bIgnoreFolder, fso.GetFileName(sFile), sFile), bIgnoreFolder) + If document_ Is Nothing Then _ + Exit Function + If document_.ReadOnly And Not bReadOnly Then + Set document_ = Nothing + Exit Function + End If + + bOwnsDoc_ = False + TryAlreadyOpened = True +End Function + +Private Function TestFile(sFile$, bReadOnly As Boolean, bIgnoreFolder As Boolean) As Boolean + Const ATTRIBUTE_READONLY = 1 + TestFile = False + + Dim fso As New Scripting.FileSystemObject + If Not bIgnoreFolder And Not fso.FileExists(sFile) Then + Call Report("Файл не найден: " & sFile) + Exit Function + End If + + If Not bReadOnly And fso.FileExists(sFile) Then + If fso.GetFile(sFile).Attributes And ATTRIBUTE_READONLY Then + Call Report("Файл ReadOnly: " & sFile) + Exit Function + End If + If Not bIgnoreFolder Then + If IsFileInUse(sFile) Then + Call Report("Файл заблокирован: " & sFile) + Exit Function + End If + End If + End If + + TestFile = True +End Function + +Private Function FindByName(sName$, bIgnoreFolder As Boolean) As Excel.Workbook + Dim aBook As Excel.Workbook + For Each aBook In application_.Workbooks + If bIgnoreFolder And aBook.Name = sName Or _ + Not bIgnoreFolder And aBook.FullName = sName Then + Set FindByName = aBook + Exit Function + End If + Next aBook +End Function + +Private Function IsFileInUse(sFileName$) As Boolean + Dim nFile%: nFile = FreeFile + On Error Resume Next + + Open sFileName For Binary Access Read Lock Read Write As #nFile + Close #nFile + IsFileInUse = Err.Number > 0 + + On Error GoTo 0 +End Function + +Private Function GetSaveFormat(sExtension$, ByRef nFormat As Excel.XlFileFormat) As Boolean + GetSaveFormat = True + Select Case VBA.UCase(sExtension) + Case "XLSX": nFormat = xlOpenXMLWorkbook + Case "XLSM": nFormat = xlOpenXMLWorkbookMacroEnabled + Case "XLTX": nFormat = xlOpenXMLTemplate + Case "XLTM": nFormat = xlOpenXMLTemplateMacroEnabled + Case "XLAM": nFormat = xlOpenXMLAddIn + Case "TXT": nFormat = xlText + Case "CSV": nFormat = xlCSV + Case "PDF": nFormat = xlTypePDF + Case Else: GetSaveFormat = False + End Select +End Function diff --git a/api/ex_ConceptCore.bas b/api/ex_ConceptCore.bas new file mode 100644 index 0000000..9f32d94 --- /dev/null +++ b/api/ex_ConceptCore.bas @@ -0,0 +1,117 @@ +Attribute VB_Name = "ex_ConceptCore" +'================ CCL wrapper ========================= +' Shared module version: 20220713 +' Tested in: +' Depends on: +' Required reference: +Option Private Module +Option Explicit + +Private Const CONCEPT_DLL_LOCATION = "C:\Tools\dll" + +#If Win64 Then + Private Const CCL_DLL_NAME = "ConceptCore64.dll" + Private Declare PtrSafe Function ConvertToASCII Lib "ConceptCore64.dll" ( _ + ByRef vResult As Variant, ByRef vText As Variant) As Long + Private Declare PtrSafe Function ConvertToMath Lib "ConceptCore64.dll" ( _ + ByRef vResult As Variant, ByVal sText As String) As Long + Private Declare PtrSafe Function ASTasText Lib "ConceptCore64.dll" ( _ + ByRef vResult As Variant, ByVal sText As String) As Long +#Else + Private Const CCL_DLL_NAME = "ConceptCore32.dll" + Private Declare PtrSafe Function ConvertToASCII Lib "ConceptCore32.dll" ( _ + ByRef vResult As Variant, ByRef vText As Variant) As Long + Private Declare PtrSafe Function ConvertToMath Lib "ConceptCore32.dll" ( _ + ByRef vResult As Variant, ByVal sText As String) As Long + Private Declare PtrSafe Function ASTasText Lib "ConceptCore32.dll" ( _ + ByRef vResult As Variant, ByVal sText As String) As Long +#End If + +Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal sLibrary As String) As Long +Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal nLibraryHandle As Long) As Long +Private Const HRESULT_OK = 0 + +Private g_IsConceptLoaded As Boolean + +Public Function LoadConceptCore() + If g_IsConceptLoaded Then _ + Exit Function + g_IsConceptLoaded = True + + If LoadLibrary(CCL_DLL_NAME) <> 0 Then _ + Exit Function + + If LoadLibrary(CONCEPT_DLL_LOCATION & "\" & CCL_DLL_NAME) <> 0 Then _ + Exit Function + + ' TODO: remove fallback after some time + ' fallback path for earlier versions of distribution + If LoadLibrary(VBA.Environ("USERPROFILE") & "\.concept\dll\" & CCL_DLL_NAME) = 0 Then _ + Call Err.Raise(1, Description:="Could not load " & CCL_DLL_NAME) +End Function + +Public Function UnloadConceptCore() + If Not g_IsConceptLoaded Then _ + Exit Function + Dim nHandle&: nHandle = LoadLibrary(CCL_DLL_NAME) + Call FreeLibrary(nHandle) +End Function + +Public Function MathToASCII(sText$) As String + On Error GoTo HANDLE_ERROR + + LoadConceptCore + + Dim vText As Variant: vText = sText + Dim vResult As Variant + If ConvertToASCII(vResult, vText) <> HRESULT_OK Then _ + MathToASCII = "ERR: " + MathToASCII = MathToASCII & vResult + + On Error GoTo 0 + Exit Function + +HANDLE_ERROR: + Debug.Print Err.Description + MathToASCII = Err.Description + On Error GoTo 0 +End Function + +Public Function ASCIItoMath(sText$) As String + On Error GoTo HANDLE_ERROR + + LoadConceptCore + + Dim vResult As Variant + If ConvertToMath(vResult, sText) <> HRESULT_OK Then _ + ASCIItoMath = "ERR: " + ASCIItoMath = ASCIItoMath & " " & vResult + + On Error GoTo 0 + Exit Function + +HANDLE_ERROR: + Debug.Print Err.Description + ASCIItoMath = Err.Description + On Error GoTo 0 +End Function + +Public Function ASCIItoAST(sText$) As String + On Error GoTo HANDLE_ERROR + + LoadConceptCore + + Dim vResult As Variant + If ASTasText(vResult, sText) <> HRESULT_OK Then _ + ASCIItoAST = "ERR: " + ASCIItoAST = ASCIItoAST & vResult + + On Error GoTo 0 + Exit Function + +HANDLE_ERROR: + Debug.Print Err.Description + ASCIItoAST = Err.Description + On Error GoTo 0 +End Function + diff --git a/api/ex_Metadata.bas b/api/ex_Metadata.bas new file mode 100644 index 0000000..d5f44f0 --- /dev/null +++ b/api/ex_Metadata.bas @@ -0,0 +1,40 @@ +Attribute VB_Name = "ex_Metadata" +'================ Модуль для работы с данными документа ============= +' Shared module version: 20210506 +' Depends on: +' Required reference: Scripting +Option Private Module +Option Explicit + +Public Function MetadataExists(iDoc As Object, varName$) As Boolean + Dim aVar As Variant + For Each aVar In iDoc.Variables + If aVar.Name = varName Then + MetadataExists = True + Exit Function + End If + Next aVar + MetadataExists = False +End Function + +Public Function GetMetadata(iDoc As Object, varName$) As Variant + Dim aVar As Variant + For Each aVar In iDoc.Variables + If aVar.Name = varName Then + GetMetadata = aVar.Value + Exit Function + End If + Next aVar + GetMetadata = "" +End Function + +Public Function SetMetadata(iDoc As Object, varName$, val As Variant) + Dim aVar As Variant + For Each aVar In iDoc.Variables + If aVar.Name = varName Then + aVar.Value = val + Exit Function + End If + Next aVar + Call iDoc.Variables.Add(varName, val) +End Function diff --git a/api/ex_Python.bas b/api/ex_Python.bas new file mode 100644 index 0000000..93af1be --- /dev/null +++ b/api/ex_Python.bas @@ -0,0 +1,125 @@ +Attribute VB_Name = "ex_Python" +' ======== Python runner extension ======== +' Shared module version: 20240330 +' Tested in: PythonManager +' Depends on: ex_VBA, ex_WinAPI, API_Config +' Required reference: Scripting +Option Private Module +Option Explicit + +' Switch flag for Debug purposes +Private Const SHOW_PYTHON = False + +Public Const PY_KEY_INTERPRETER = "Python3" +Public Const PY_KEY_SOURCE_PATH = "PythonImports" + +Public Const PY_MODULE_TEXT = "cctext" +Public Const PY_MODULE_UTILS = "vbatopy" + +Public Const PY_DEFVALUE_INTERPRETER = "C:\Tools\Python312-venv\Scripts\python.exe" + +Public Function AccessPython() As API_Python + Static s_Python As API_Python + If s_Python Is Nothing Then + Set s_Python = New API_Python + Call s_Python.Init( _ + iPython:=ConceptConfig.GetValue(PY_KEY_INTERPRETER), _ + sModules:=OfficeActivePath & ";" & ConceptConfig.GetValue(PY_KEY_SOURCE_PATH), _ + bDoDebug:=SHOW_PYTHON) + End If + Set AccessPython = s_Python +End Function + +Public Function ConceptConfig() As API_Config + Dim iConfig As New API_Config + Set ConceptConfig = iConfig + If Not iConfig.LoadFromFile(ConceptConfigPath()) Then _ + Call LoadDefaultConfig(iConfig) +End Function + +' Runs the Python command, e.g.: Call RunPython("import bar; bar.foo()", ThisWorkbook.Path) +Public Function RunPyStandalone(sPyCommand$, Optional sWorkDir$ = vbNullString) As Long + Dim iConfig As API_Config: Set iConfig = ConceptConfig + Dim iPython$: iPython = iConfig.GetValue(PY_KEY_INTERPRETER) + Dim sSource$ + If Not sWorkDir = vbNullString Then _ + sSource = sWorkDir & ";" + sSource = sSource & iConfig.GetValue(PY_KEY_SOURCE_PATH) + If sSource <> "" Then _ + sSource = sSource & ";" + sSource = VBA.Replace(sSource, "&", "^&") + sSource = VBA.Replace(sSource, "\", "\\") + + Dim sChangeDir$: sChangeDir = GenerateCDCommandFor(iPython) + Dim sExtendedPyCommand$: sExtendedPyCommand = Fmt( _ + "{1} & ""{2}"" -B -c " & _ + """import sys, os; sys.path[0:0]=os.path.normcase(os.path.expandvars(\""{3}\"")).split(';'); " & _ + "{4}""", _ + sChangeDir, iPython, sSource, sPyCommand) + + RunPyStandalone = PyExecute(sExtendedPyCommand) +End Function + +' Runs a Python executable that has been frozen by PyInstaller and the like +' Call RunFrozenPython("C:\path\to\frozen_executable.exe", "arg1 arg2") +Public Function RunPyFrozen(iPython$, Optional sArgs$ = vbNullString) As Long + Dim sChangeDir$: sChangeDir = GenerateCDCommandFor(iPython) + Dim sPyCommand$: sPyCommand = Fmt("{1} & ""{2}"" {3}", sChangeDir, iPython, sArgs) + RunPyFrozen = PyExecute(sPyCommand) +End Function + +Public Function ConceptConfigPath() As String + ConceptConfigPath = VBA.Environ$("USERPROFILE") & "\.concept\concept-options.json" +End Function + +' ======== +Private Function PyExecute(sPyCommand$) As Long + Dim sLog$: sLog = GetLogFile() + + Dim sShellCommand$: sShellCommand = Fmt("cmd.exe /C {1} 2> ""{3}""", _ + sPyCommand, sLog) + + Dim nWindowStyle%: nWindowStyle = IIf(SHOW_PYTHON, 1, 0) + Dim iShell As Object: Set iShell = CreateObject("WScript.Shell") + Dim nExitCode&: nExitCode = iShell.Run(sShellCommand, nWindowStyle, True) + + If nExitCode <> 0 Then + Call MsgBox(ReadTextFile(sLog), vbCritical) + PyExecute = -1 + End If + + On Error Resume Next + Call Kill(sLog) + On Error GoTo 0 + + Set iShell = Nothing +End Function + +Private Function LoadDefaultConfig(ByRef iConfig As API_Config) + Call iConfig.SetValue(PY_KEY_INTERPRETER, PY_DEFVALUE_INTERPRETER) + Call iConfig.SetValue(PY_KEY_SOURCE_PATH, "") +End Function + +Private Function GenerateCDCommandFor(sFile$) As String + Dim fso As New Scripting.FileSystemObject + GenerateCDCommandFor = Fmt("{1} & cd ""{2}""", VBA.Left(sFile, 2), fso.GetParentFolderName(sFile$)) +End Function + +Private Function GetLogFile() As String + GetLogFile = Fmt("{1}\pymanager-{2}.log", VBA.Environ("Temp"), GetCurrentProcessId()) +End Function + +Private Function ReadTextFile(sFile$) As String + Dim adoStream As Object: Set adoStream = CreateObject("ADODB.Stream") + adoStream.Charset = "utf-8" + Call adoStream.Open + + On Error GoTo ERROR_FILE + Call adoStream.LoadFromFile(sFile) + On Error GoTo 0 + + ReadTextFile = adoStream.ReadText + +ERROR_FILE: + Call adoStream.Close +End Function diff --git a/api/ex_WinAPI.bas b/api/ex_WinAPI.bas new file mode 100644 index 0000000..77d4933 --- /dev/null +++ b/api/ex_WinAPI.bas @@ -0,0 +1,541 @@ +Attribute VB_Name = "ex_WinAPI" +' ================ Модуль для работы с функциями уровня приложения ============= +' Shared module version: 20220812 +' Tested in: TestCommons +' Depends on: +' Required reference: Scripting, Shell32 +Option Private Module +Option Explicit + +Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal nMilliseconds As LongPtr) +Public Declare PtrSafe Function GetCurrentProcessId Lib "kernel32" () As Long +Public Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal nHwnd As Long, nProcID As Long) As Long +Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long +Public Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" _ + (ByVal nHwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long + +Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal nHwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long +Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal nHwnd As Long, ByVal nDEvent As Long) As Long + +Private Const DATAOBJECT_BINDING$ = "new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}" ' ID Для объекта DataObject + +Private Declare PtrSafe Function BringWindowToTop Lib "user32" (ByVal nHwnd As Long) As Long +Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal nHwnd As Long) As Long + +Private Declare PtrSafe Function GetCommandLine Lib "kernel32" Alias "GetCommandLineW" () As LongPtr +Private Declare PtrSafe Function lstrlenW Lib "kernel32" (ByVal lpString As LongPtr) As Long +Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (iDestination As Any, iSource As Any, ByVal nLength As LongPtr) + +Public Enum TApplication + T_APP_UNDEF = 0 + [_First] = 1 + + T_APP_EXCEL = 1 + T_APP_WORD = 2 + T_APP_VISIO = 3 + + [_Last] = 3 +End Enum + +Public Function OfficeCommandLine() As String + OfficeCommandLine = String$(lstrlenW(GetCommandLine()), 0) + Call CopyMemory(ByVal StrPtr(OfficeCommandLine), ByVal GetCommandLine(), LenB(OfficeCommandLine)) +End Function + +Public Function ActivateWindow(sClass$, Optional sWindow$ = vbNullString) As Boolean + On Error Resume Next + ActivateWindow = False + Dim nWindow&: nWindow = FindWindow(sClass, sWindow) + If nWindow <= 0 Then _ + Exit Function + ActivateWindow = ActivateWindowHwnd(nWindow) +End Function + +Public Function ActivateWindowHwnd(nWindow&) As Boolean + On Error Resume Next + ActivateWindowHwnd = False + If nWindow <= 0 Then _ + Exit Function + If BringWindowToTop(nWindow) = 0 Then _ + Exit Function + + Call SetFocus(nWindow) + ActivateWindowHwnd = True +End Function + +Public Function ApplicationFromExtension(sExtension$) As TApplication + ApplicationFromExtension = T_APP_UNDEF + Select Case VBA.UCase(sExtension) + Case "XLS": ApplicationFromExtension = T_APP_EXCEL + Case "XLSX": ApplicationFromExtension = T_APP_EXCEL + Case "XLSM": ApplicationFromExtension = T_APP_EXCEL + Case "XLTM": ApplicationFromExtension = T_APP_EXCEL + Case "RTF": ApplicationFromExtension = T_APP_WORD + Case "DOC": ApplicationFromExtension = T_APP_WORD + Case "DOCX": ApplicationFromExtension = T_APP_WORD + Case "DOCM": ApplicationFromExtension = T_APP_WORD + Case "DOTM": ApplicationFromExtension = T_APP_WORD + Case "VSDX": ApplicationFromExtension = T_APP_VISIO + Case "VSDM": ApplicationFromExtension = T_APP_VISIO + Case "VSTX": ApplicationFromExtension = T_APP_VISIO + Case "VSTM": ApplicationFromExtension = T_APP_VISIO + End Select +End Function + +Public Function ApplicationTypeFor(iApp As Object) As TApplication + ApplicationTypeFor = T_APP_UNDEF + Select Case iApp.Name + Case "Microsoft Excel": ApplicationTypeFor = T_APP_EXCEL + Case "Microsoft Word": ApplicationTypeFor = T_APP_WORD + Case "Microsoft Visio": ApplicationTypeFor = T_APP_VISIO + End Select +End Function + +Public Function ApplicationWrapper(iType As TApplication) As Object + Dim iApplication As Object: Set iApplication = Application + If Application.Name = "Microsoft Visio" Then _ + Call Err.Raise(vbObjectError, Description:="Visio does not support meta wrappers") + Select Case iType + Case T_APP_EXCEL: Set ApplicationWrapper = iApplication.Run("CreateWrapperXL") + Case T_APP_WORD: Set ApplicationWrapper = iApplication.Run("CreateWrapperWord") + Case T_APP_VISIO: Set ApplicationWrapper = iApplication.Run("CreateWrapperVisio") + End Select +End Function + +' To use application wrapper copy required CreateWrapper functions to Main module and uncomment them +'Public Function CreateWrapperXL() As API_XLWrapper +' Set CreateWrapperXL = New API_XLWrapper +'End Function +' +'Public Function CreateWrapperWord() As API_WordWrapper +' Set CreateWrapperWord = New API_WordWrapper +'End Function +' +'Public Function CreateWrapperVisio() As API_VisioWrapper +' Set CreateWrapperVisio = New API_VisioWrapper +'End Function + +' Wrapper for active document +Public Function OfficeActiveWrapper() As Object + Dim activeApp As Object: Set activeApp = Application + Dim iWrapper As Object + + Select Case ApplicationTypeFor(Application) + Case T_APP_EXCEL + Set iWrapper = ApplicationWrapper(T_APP_EXCEL) + Call iWrapper.SetDocument(activeApp.ActiveWorkbook) + + Case T_APP_WORD + Set iWrapper = ApplicationWrapper(T_APP_WORD) + Call iWrapper.SetDocument(activeApp.ActiveDocument) + + Case T_APP_VISIO + Set iWrapper = ApplicationWrapper(T_APP_VISIO) + Call iWrapper.SetDocument(activeApp.ActiveDocument) + End Select + + Set OfficeActiveWrapper = iWrapper +End Function + +' Wrapper for this document +Public Function OfficeThisWrapper() As Object + Dim activeApp As Object: Set activeApp = Application + Dim iWrapper As Object + + Select Case ApplicationTypeFor(Application) + Case T_APP_EXCEL + Set iWrapper = ApplicationWrapper(T_APP_EXCEL) + Call iWrapper.SetDocument(activeApp.ThisWorkbook) + + Case T_APP_WORD + Set iWrapper = ApplicationWrapper(T_APP_WORD) + Call iWrapper.SetDocument(activeApp.ThisDocument) + + Case T_APP_VISIO + Set iWrapper = ApplicationWrapper(T_APP_VISIO) + Call iWrapper.SetDocument(activeApp.ThisDocument) + End Select + + Set OfficeThisWrapper = iWrapper +End Function + +' Path to active document folder +Public Function OfficeActivePath() As String + Dim activeApp As Object: Set activeApp = Application + Select Case ApplicationTypeFor(Application) + Case T_APP_EXCEL: OfficeActivePath = activeApp.ActiveWorkbook.Path + Case T_APP_WORD: OfficeActivePath = activeApp.ActiveDocument.Path + Case T_APP_VISIO: OfficeActivePath = activeApp.ActiveDocument.Path + End Select +End Function + +' Path to this document folder +Public Function OfficeThisPath() As String + Dim activeApp As Object: Set activeApp = Application + Select Case ApplicationTypeFor(Application) + Case T_APP_EXCEL: OfficeThisPath = activeApp.ThisWorkbook.Path + Case T_APP_WORD: OfficeThisPath = activeApp.ThisDocument.Path + Case T_APP_VISIO: OfficeThisPath = activeApp.ThisDocument.Path + End Select +End Function + +Public Function AddToClipboard(sText$) + With CreateObject(DATAOBJECT_BINDING) + Call .SetText(sText) + .PutInClipboard + End With +End Function + +Public Function RetrieveFromClipboard() As String + With CreateObject(DATAOBJECT_BINDING) + Call .GetFromClipboard + RetrieveFromClipboard = .GetText + End With +End Function + +Public Function WindowsTempFolder() As String + WindowsTempFolder = Environ("TEMP") +End Function + +Public Function EnsureFolderExists(sPath$, Optional ByRef fso As Scripting.FileSystemObject = Nothing) + If fso Is Nothing Then _ + Set fso = New Scripting.FileSystemObject + If fso.FolderExists(sPath) Then _ + Exit Function + + Dim sParent$: sParent = sPath + Do + If sParent = vbNullString Then _ + Exit Function + If VBA.Right(sParent, 1) <> "\" Then _ + Exit Do + sParent = VBA.Left(sParent, VBA.Len(sParent) - 1) + Loop + + Dim nDelim&: nDelim = VBA.InStrRev(sParent, "\") + If nDelim = 0 Then _ + Exit Function + sParent = VBA.Left(sParent, nDelim - 1) + + Call EnsureFolderExists(sParent, fso) + Call fso.CreateFolder(sPath) +End Function + +Public Function CreateTextFileUTF16(sFile$, Optional bOverwrite = False) As Boolean + CreateTextFileUTF16 = False + + Dim fso As New Scripting.FileSystemObject + If Not bOverwrite Then _ + If fso.FileExists(sFile) Then _ + Exit Function + + On Error GoTo EXIT_FALSE + Call fso.CreateTextFile(sFile, Overwrite:=bOverwrite, Unicode:=True).Close + On Error GoTo 0 + + CreateTextFileUTF16 = True + Exit Function +EXIT_FALSE: +End Function + +Public Function AppendTextToFileUTF16(sFile$, sMsg$) As Boolean + Const UTF16_MODE = TristateTrue + AppendTextToFileUTF16 = False + + Dim fso As New Scripting.FileSystemObject + If Not fso.FileExists(sFile) Then _ + Exit Function + + On Error GoTo RETURN_FALSE + Dim fs As Scripting.TextStream + Set fs = fso.OpenTextFile(sFile, ForAppending, Format:=UTF16_MODE) + If fs Is Nothing Then _ + Exit Function + + Call fs.WriteLine(sMsg) + Call fs.Close + + AppendTextToFileUTF16 = True + Exit Function +RETURN_FALSE: +End Function + +Public Function ReadTextFromFileUTF16(sFile$, ByRef sResult$) As Boolean + Const UTF16_MODE = TristateTrue + ReadTextFromFileUTF16 = False + + Dim fso As New Scripting.FileSystemObject + If Not fso.FileExists(sFile) Then _ + Exit Function + + On Error GoTo RETURN_FALSE + Dim fs As Scripting.TextStream + Set fs = fso.OpenTextFile(sFile, ForReading, Format:=UTF16_MODE) + If fs Is Nothing Then _ + Exit Function + + sResult = fs.ReadAll + Call fs.Close + + ReadTextFromFileUTF16 = True + Exit Function +RETURN_FALSE: +End Function + +Public Function CopyFileOrFolder(sSource$, sDestination$, Optional ByRef fso As Scripting.FileSystemObject = Nothing) As Boolean + CopyFileOrFolder = False + + If fso Is Nothing Then _ + Set fso = New Scripting.FileSystemObject + + Dim bIsFile As Boolean: bIsFile = fso.FileExists(sSource) + Dim bIsFolder As Boolean: bIsFolder = fso.FolderExists(sSource) + If Not bIsFile And Not bIsFolder Then _ + Exit Function + + Call EnsureFolderExists(fso.GetParentFolderName(sDestination), fso) + On Error GoTo RETURN_FALSE + If bIsFile Then + Call fso.CopyFile(sSource, sDestination, OverWriteFiles:=True) + Else + Call fso.CopyFolder(sSource, sDestination, OverWriteFiles:=True) + End If + On Error GoTo 0 + + CopyFileOrFolder = True +RETURN_FALSE: +End Function + +Public Function MoveFileOrFolder(sSource$, sDestination$, Optional fso As Scripting.FileSystemObject = Nothing) As Boolean + MoveFileOrFolder = False + If sSource = sDestination Then _ + Exit Function + If Not CopyFileOrFolder(sSource, sDestination, fso) Then _ + Exit Function + + On Error GoTo RETURN_FALSE + If fso.FileExists(sSource) Then _ + Call fso.DeleteFile(sSource) + If fso.FolderExists(sSource) Then _ + Call fso.DeleteFolder(sSource) + On Error GoTo 0 + + MoveFileOrFolder = True + Exit Function + +RETURN_FALSE: + MoveFileOrFolder = False +End Function + +Public Function ListFilesIn(sTargetFolder$, Optional sMask$ = "*.*") As Collection + Dim fso As New Scripting.FileSystemObject + If Not fso.FolderExists(sTargetFolder) Then _ + Exit Function + + Dim iFiles As New Collection + Dim cQueue As New Collection + Call cQueue.Add(fso.GetFolder(sTargetFolder)) + + Dim aFolder As Scripting.Folder + Dim subFolder As Scripting.Folder + Dim aFile As Scripting.File + Do While cQueue.Count > 0 + Set aFolder = cQueue(1) + Call cQueue.Remove(1) + + For Each subFolder In aFolder.SubFolders + Call cQueue.Add(subFolder) + Next subFolder + + For Each aFile In aFolder.files + If VBA.UCase(aFile.Name) Like VBA.UCase(sMask) Then _ + Call iFiles.Add(aFile.Path) + Next aFile + Loop + + Set ListFilesIn = iFiles +End Function + +Public Function ForEachFileRecursive(sTargetFolder$, oCallback As Object, sFuncName$) + Dim fso As New Scripting.FileSystemObject + If Not fso.FolderExists(sTargetFolder) Then _ + Exit Function + + Dim cQueue As New Collection + Call cQueue.Add(fso.GetFolder(sTargetFolder)) + + Dim aFolder As Scripting.Folder + Dim subFolder As Scripting.Folder + Dim aFile As Scripting.File + Do While cQueue.Count > 0 + Set aFolder = cQueue(1) + Call cQueue.Remove(1) + + For Each subFolder In aFolder.SubFolders + Call cQueue.Add(subFolder) + Next subFolder + + For Each aFile In aFolder.files + Call CallByName(oCallback, sFuncName, VbMethod, aFile) + Next aFile + Loop +End Function + +' Callback should return TRUE to continue recursive +Public Function ForEachFolderRecursive(sTargetFolder$, oCallback As Object, sFuncName$) + Dim fso As New Scripting.FileSystemObject + If Not fso.FolderExists(sTargetFolder) Then _ + Exit Function + + Dim cQueue As New Collection + Call cQueue.Add(fso.GetFolder(sTargetFolder)) + + Dim aFolder As Scripting.Folder + Dim subFolder As Scripting.Folder + Dim aFile As Scripting.File + Do While cQueue.Count > 0 + Set aFolder = cQueue(1) + Call cQueue.Remove(1) + + If CallByName(oCallback, sFuncName, VbMethod, aFolder) Then + For Each subFolder In aFolder.SubFolders + Call cQueue.Add(subFolder) + Next subFolder + End If + Loop +End Function + +Public Function FileToMD5(sTargetFile$) As String + FileToMD5 = ComputeFileHash(sTargetFile, "MD5CryptoServiceProvider") +End Function + +Public Function FileToSHA1(sTargetFile$) As String + FileToSHA1 = ComputeFileHash(sTargetFile, "SHA1CryptoServiceProvider") +End Function + +Public Function UnzipFile(sTargetFile$, sDestinationFolder$) As Boolean + Const OPT_DISABLE_DIALOGS = 4 + Const OPT_YES_TO_ALL = 16 + + UnzipFile = False + + Dim fso As New Scripting.FileSystemObject + If Not fso.FileExists(sTargetFile) Then _ + Exit Function + + Dim sExt$: sExt = fso.GetExtensionName(sTargetFile) + Dim sZip$: sZip = sTargetFile + If sExt <> "zip" Then + sZip = Left(sTargetFile, Len(sTargetFile) - Len(sExt) - 1) & ".tmp.zip" + Call fso.GetFile(sTargetFile).Copy(sZip) + End If + + Call EnsureFolderExists(sDestinationFolder, fso) + + Dim aShell As New Shell32.Shell + Call aShell.Namespace(sDestinationFolder).CopyHere(aShell.Namespace(sZip).Items, OPT_DISABLE_DIALOGS + OPT_YES_TO_ALL) + + If sExt <> "zip" Then _ + Call fso.DeleteFile(sZip) + + UnzipFile = True +End Function + +Public Function ZipFolder(sTargetFolder$, sDestinationFile$) As Boolean + ZipFolder = False + + Dim fso As New Scripting.FileSystemObject + If Not fso.FolderExists(sTargetFolder) Then _ + Exit Function + + Dim sZip$: sZip = sDestinationFile + Dim sExt$: sExt = fso.GetExtensionName(sDestinationFile) + If sExt <> "zip" Then _ + sZip = Left(sDestinationFile, Len(sDestinationFile) - Len(sExt) - 1) & ".zip" + + Call CreateEmptyZip(sZip) + Dim aShell As New Shell32.Shell + Call aShell.Namespace(sZip).CopyHere(aShell.Namespace(sTargetFolder).Items) + +' Wait for zipping to finish + On Error Resume Next + Dim nTimeout&: nTimeout = 90 ' seconds + Do Until aShell.Namespace(sZip).Items.Count = aShell.Namespace(sTargetFolder).Items.Count + Call Sleep(1000) + nTimeout = nTimeout - 1 + If nTimeout = 0 Then _ + Exit Function + Loop + On Error GoTo 0 + + If sExt <> "zip" Then + Call fso.CopyFile(sZip, sDestinationFile) + Call fso.DeleteFile(sZip) + End If + + ZipFolder = True +End Function + +Public Function PositionInMiddle(targetForm As Object) + Dim nTopOffset&: nTopOffset = (Application.UsableHeight / 2) - (targetForm.Height / 2) + Dim nLeftOffset&: nLeftOffset = (Application.UsableWidth / 2) - (targetForm.Width / 2) + + targetForm.StartUpPosition = 0 + targetForm.Top = Application.Top + IIf(nTopOffset > 0, nTopOffset, 0) + targetForm.Left = Application.Left + IIf(nLeftOffset > 0, nLeftOffset, 0) +End Function + +' ======== +Private Function CreateEmptyZip(sTarget$) + Dim nFileID%: nFileID = FreeFile + Open sTarget For Output As #nFileID + Print #nFileID, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) + Close #nFileID +End Function + +Private Function ComputeFileHash(sTargetFile$, sCryptoProvider$) As String + Dim fso As New Scripting.FileSystemObject + If Not fso.FileExists(sTargetFile) Then + ComputeFileHash = "File not exists" + Exit Function + End If + + Dim nFileID&: nFileID = VBA.FreeFile + On Error GoTo CANNOT_OPEN + Open sTargetFile For Binary Access Read As nFileID + On Error GoTo 0 + + Dim iEncrypter As Object: Set iEncrypter = CreateObject("System.Security.Cryptography." & sCryptoProvider) + Dim iBuffer() As Byte + Dim nBlockSize&: nBlockSize = 2 ^ 16 + Dim nFileSize&: nFileSize = VBA.LOF(nFileID) + If nFileSize < nBlockSize Then _ + nBlockSize = ((nFileSize + 1024) \ 1024) * 1024 + + ReDim iBuffer(0 To nBlockSize - 1) + Dim i& + For i = 1 To nFileSize \ nBlockSize Step 1 + Get nFileID, , iBuffer + Call iEncrypter.TransformBlock(iBuffer, 0, nBlockSize, iBuffer, 0) + Next + + Get nFileID, , iBuffer + Call iEncrypter.TransformFinalBlock(iBuffer, 0, nFileSize Mod nBlockSize) + iBuffer = iEncrypter.Hash + + Close nFileID + Call iEncrypter.Clear + + Dim nPos& + Dim sHash$ + For nPos = 1 To VBA.LenB(iBuffer) + sHash = sHash & VBA.LCase(VBA.Right("0" & VBA.Hex(VBA.AscB(VBA.MidB(iBuffer, nPos, 1))), 2)) + Next nPos + + Set iEncrypter = Nothing + ComputeFileHash = sHash + Exit Function + +CANNOT_OPEN: + ComputeFileHash = "Cannot open file" +End Function diff --git a/api/z_LoadPictureAPI.bas b/api/z_LoadPictureAPI.bas new file mode 100644 index 0000000..df8ea02 --- /dev/null +++ b/api/z_LoadPictureAPI.bas @@ -0,0 +1,97 @@ +Attribute VB_Name = "z_LoadPictureAPI" +'================ Модуль загрузки изображения через GDI ============= +' Shared module version: 20210228 +' Required reference: +Option Private Module +Option Explicit + +'Declare a UDT to store a GUID for the IPicture OLE Interface +Private Type GUID + Data1 As Long + Data2 As Integer + Data3 As Integer + Data4(0 To 7) As Byte +End Type + +'Declare a UDT to store the bitmap information +Private Type PictDescriptor + size_ As LongLong + type_ As LongLong + hPic_ As LongPtr + hPal_ As LongLong +End Type + +'Declare a UDT to store the GDI+ Startup information +Private Type GdiplusStartupInput + version_ As Long + callback_ As LongPtr + suppBgThread_ As LongLong + suppExtCodecs_ As LongLong +End Type + +'Windows API calls into the GDI+ library +Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (pToken As LongPtr, pInputBuf As GdiplusStartupInput, Optional ByVal pOutputBuf As LongPtr = 0) As Long +Private Declare PtrSafe Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal pFile As LongPtr, pBitmap As LongPtr) As Long +Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal pBitmap As LongPtr, hbmReturn As LongPtr, ByVal pBackground As LongPtr) As Long +Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" (ByVal pImage As LongPtr) As Long +Private Declare PtrSafe Function GdiplusShutdown Lib "GDIPlus" (ByVal pToken As LongPtr) As Long +Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As PictDescriptor, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, iPic As IPicture) As LongPtr + +Private Const PICTYPE_BITMAP = 1 + +' Procedure: LoadPictureGDI +' Purpose: Loads an image using GDI+ +' Returns: The image as an IPicture Object +Public Function LoadPictureGDI(ByVal sFileName$) As IPicture + 'Initialize GDI+ + Dim uGdiInput As GdiplusStartupInput + uGdiInput.version_ = 1 + Dim hGdiPlus As LongPtr + Dim lResult&: lResult = GdiplusStartup(hGdiPlus, uGdiInput) + + If lResult <> 0 Then _ + Exit Function + + Dim hGdiImage As LongPtr + If GdipCreateBitmapFromFile(StrPtr(sFileName), hGdiImage) = 0 Then + Dim hBitmap As LongPtr + Call GdipCreateHBITMAPFromBitmap(hGdiImage, hBitmap, 0) + Set LoadPictureGDI = CreateIPicture(hBitmap) + Call GdipDisposeImage(hGdiImage) + End If + + Call GdiplusShutdown(hGdiPlus) +End Function + +' Procedure: CreateIPicture +' Purpose: Converts a image handle into an IPicture object. +' Returns: The IPicture object +Private Function CreateIPicture(ByVal hPic As LongPtr) As IPicture + Dim IID_IDispatch As GUID + With IID_IDispatch + .Data1 = &H7BF80980 + .Data2 = &HBF32 + .Data3 = &H101A + .Data4(0) = &H8B + .Data4(1) = &HBB + .Data4(2) = &H0 + .Data4(3) = &HAA + .Data4(4) = &H0 + .Data4(5) = &H30 + .Data4(6) = &HC + .Data4(7) = &HAB + End With + + Dim uPicInfo As PictDescriptor + With uPicInfo + .size_ = Len(uPicInfo) + .type_ = PICTYPE_BITMAP + .hPic_ = hPic + .hPal_ = 0 + End With + + Dim iPic As IPicture + Call OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, iPic) + Set CreateIPicture = iPic +End Function + diff --git a/api/z_PastePictureAPI.bas b/api/z_PastePictureAPI.bas new file mode 100644 index 0000000..e8b21b2 --- /dev/null +++ b/api/z_PastePictureAPI.bas @@ -0,0 +1,156 @@ +Attribute VB_Name = "z_PastePictureAPI" +'================ Модуль загрузки изображения через Copy/Paste ============= +' Shared module version: 20210228 +' Required reference: OLE Automation + +' PastePicture The entry point for the routine +' CreatePicture Private function to convert a bitmap or metafile handle to an OLE reference +' ErrorDescription Get the error text for an OLE error code +Option Private Module +Option Explicit +Option Compare Text + +' Declare a UDT to store a GUID for the IPicture OLE Interface +Private Type GUID + Data1 As Long + Data2 As Integer + Data3 As Integer + Data4(0 To 7) As Byte +End Type + +' Declare a UDT to store the bitmap information +Private Type PictDescriptor + size_ As LongLong + type_ As LongLong + hPic_ As LongPtr + hPal_ As LongLong +End Type + +'Does the clipboard contain a bitmap/metafile? +Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long + +Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long +Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long +Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long + +'Convert the handle into an OLE IPicture interface. +Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" (pDesct As PictDescriptor, refID As GUID, ByVal nPicHandle As Long, iPic As IPicture) As Long + +'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates. +Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long + +'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates. +Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal nHandle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long + +'The API format types +Private Const CF_BITMAP = 2 +Private Const CF_PALETTE = 9 +Private Const CF_ENHMETAFILE = 14 +Private Const IMAGE_BITMAP = 0 +Private Const LR_COPYRETURNORG = &H4 + +Public Function PastePicture(Optional nType& = xlPicture) As IPicture + 'Convert the type of picture requested from the xl constant to the API constant + Dim lPicType&: lPicType = IIf(nType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE) + + 'Check if the clipboard contains the required format + Dim hPicAvail&: hPicAvail = IsClipboardFormatAvailable(lPicType) + If hPicAvail = 0 Then _ + Exit Function + + Dim cbHandle&: cbHandle = OpenClipboard(0&) + If cbHandle <= 0 Then _ + Exit Function + + 'Get a handle to the image data + Dim hPtr&: hPtr = GetClipboardData(lPicType) + + 'Create our own copy of the image on the clipboard, in the appropriate format. + Dim hCopy& + If lPicType = CF_BITMAP Then + hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG) + Else + hCopy = CopyEnhMetaFile(hPtr, vbNullString) + End If + + 'Release the clipboard to other programs + cbHandle = CloseClipboard + + 'If we got a handle to the image, convert it into a Picture object and return it + If hPtr <> 0 Then _ + Set PastePicture = CreatePicture(hCopy, 0, lPicType) +End Function + +Private Function CreatePicture(ByVal hPic&, ByVal hPal&, ByVal lPicType) As IPicture + 'OLE Picture types + Const PICTYPE_BITMAP = 1 + Const PICTYPE_ENHMETAFILE = 4 + + ' Create the Interface GUID (for the IPicture interface) + Dim IID_IDispatch As GUID + With IID_IDispatch + .Data1 = &H7BF80980 + .Data2 = &HBF32 + .Data3 = &H101A + .Data4(0) = &H8B + .Data4(1) = &HBB + .Data4(2) = &H0 + .Data4(3) = &HAA + .Data4(4) = &H0 + .Data4(5) = &H30 + .Data4(6) = &HC + .Data4(7) = &HAB + End With + + ' Fill uPicInfo with necessary parts. + Dim uPicInfo As PictDescriptor + With uPicInfo + .size_ = Len(uPicInfo) ' Length of structure. + .type_ = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE) ' Type of Picture + .hPic_ = hPic ' Handle to image. + .hPal_ = IIf(lPicType = CF_BITMAP, hPal, 0) ' Handle to palette (if bitmap). + End With + + ' Create the Picture object. + Dim r& + Dim iPic As IPicture + r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, iPic) + + ' If an error occured, show the description + If r <> 0 Then _ + Debug.Print "Create Picture: " & ErrorDescription(r) + + ' Return the new Picture object. + Set CreatePicture = iPic +End Function + + +Private Function ErrorDescription(nErr&) As String +'OLECreatePictureIndirect return values + Const E_ABORT = &H80004004 + Const E_ACCESSDENIED = &H80070005 + Const E_FAIL = &H80004005 + Const E_HANDLE = &H80070006 + Const E_INVALIDARG = &H80070057 + Const E_NOINTERFACE = &H80004002 + Const E_NOTIMPL = &H80004001 + Const E_OUTOFMEMORY = &H8007000E + Const E_POINTER = &H80004003 + Const E_UNEXPECTED = &H8000FFFF + Const S_OK = &H0 + + Select Case nErr + Case E_ABORT: ErrorDescription = " Aborted" + Case E_ACCESSDENIED: ErrorDescription = " Access Denied" + Case E_FAIL: ErrorDescription = " General Failure" + Case E_HANDLE: ErrorDescription = " Bad/Missing Handle" + Case E_INVALIDARG: ErrorDescription = " Invalid Argument" + Case E_NOINTERFACE: ErrorDescription = " No Interface" + Case E_NOTIMPL: ErrorDescription = " Not Implemented" + Case E_OUTOFMEMORY: ErrorDescription = " Out of Memory" + Case E_POINTER: ErrorDescription = " Invalid Pointer" + Case E_UNEXPECTED: ErrorDescription = " Unknown Error" + Case S_OK: ErrorDescription = " Success!" + End Select +End Function + diff --git a/dev/API_Logger.cls b/dev/API_Logger.cls new file mode 100644 index 0000000..7b5bc81 --- /dev/null +++ b/dev/API_Logger.cls @@ -0,0 +1,96 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "API_Logger" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ================ Log functionality ============= +' Shared module version: 20210413 +' Tested in: TestCommons +' Depends on: ex_VBA +' Required reference: Scripting +' Note: log is saved as UTF-16 encoded text file +Option Explicit + +Private fileName_ As String + +Public Function Init(sName$) + If sName = vbNullString Then _ + Exit Function + fileName_ = sName + Call EnsureOutputExists +End Function + +Public Property Get LogFileName() As String + LogFileName = fileName_ +End Property + +Public Function Log(sMsg$) + If fileName_ <> vbNullString Then + Call LogIntoFile(StampTime(sMsg)) + Else + Call LogDefault(StampTime(sMsg)) + End If +End Function + +Public Function Report(sMsg$, Optional nFlags& = 0) + ' TODO: indicate flags + Call Log(sMsg) +End Function + +Public Function Clear() + If fileName_ <> vbNullString Then _ + Call CreateLogFile +End Function + +' ========== +Private Function LogIntoFile(sMsg$) + Const UTF16_MODE = TristateTrue + + Dim fso As New Scripting.FileSystemObject + If Not fso.FileExists(fileName_) Then _ + GoTo CANNOT_ACCESS + + Dim fs As Scripting.TextStream: Set fs = fso.OpenTextFile(fileName_, ForAppending, Format:=UTF16_MODE) + If fs Is Nothing Then _ + GoTo CANNOT_ACCESS + + Call fs.WriteLine(sMsg) + Call fs.Close + Exit Function + +CANNOT_ACCESS: + Call LogDefault(StampTime("Cannot access log")) + Call LogDefault(sMsg) +End Function + +Private Function LogDefault(sMsg$) + Debug.Print sMsg +End Function + +Private Function EnsureOutputExists() + Dim fso As New Scripting.FileSystemObject + If fso.FileExists(fileName_) Then _ + Exit Function + + Call CreateLogFile +End Function + +Private Function StampTime(sMsg$) As String + StampTime = Format(Now(), "yyyy-mm-dd hh:mm:ss") & ": " & sMsg +End Function + +Private Function CreateLogFile() + Dim fso As New Scripting.FileSystemObject + Call EnsureFolderExists(fso.GetParentFolderName(fileName_)) + Dim fs As Scripting.TextStream: Set fs = fso.CreateTextFile(fileName_, Unicode:=True) + If fs Is Nothing Then + Call LogDefault(StampTime("Cannot create log: " & fileName_)) + Else + Call fs.Close + Call Log("Log file created") + End If +End Function diff --git a/dev/API_MockInteraction.cls b/dev/API_MockInteraction.cls new file mode 100644 index 0000000..52269fe --- /dev/null +++ b/dev/API_MockInteraction.cls @@ -0,0 +1,247 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "API_MockInteraction" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'================ Mock взаимодействия с пользователем ========================= +' Shared module version: 20210331 +' Depends on: DevTester, API_UserInteraction +' Required reference: +Option Explicit +Implements API_UserInteraction + +Private Enum InteractionType + T_UI_INVALID = 0 + T_UI_MESSAGE + T_UI_QUESTION + T_UI_PROMPT_INPUT + T_UI_PROMPT_FILE + T_UI_FOLLOW_HYPERLINK +End Enum + +Private Type ExpectationInfo + type_ As InteractionType + id_ As Long + response_ As String +End Type + +Private types_ As Collection ' of InteractionType +Private ids_ As Collection ' of Long +Private responses_ As Collection ' of String + +Private Sub Class_Initialize() + Call ResetCollection +End Sub + +Public Function ExpectNoInteraction() + Call ResetExpectations +End Function + +Public Function ExpectMessage(nMsg&) + Call AddExpectation(T_UI_MESSAGE, nMsg) +End Function + +Public Function ExpectQuestion(nMsg&, bAnswerYes As Boolean) + Call AddExpectation(T_UI_QUESTION, nMsg, IIf(bAnswerYes, "YES", "NO")) +End Function + +Public Function ExpectInputPrompt(sResponse$) + Call AddExpectation(T_UI_PROMPT_INPUT, sResponse:=sResponse) +End Function + +Public Function ExpectFilePrompt(sResponse$) + Call AddExpectation(T_UI_PROMPT_FILE, sResponse:=sResponse) +End Function + +Public Function ExpectFollowHyperlink(sLink$) + Call AddExpectation(T_UI_FOLLOW_HYPERLINK, sResponse:=sLink) +End Function + +Public Function ResetExpectations() As Boolean + ResetExpectations = ids_.Count = 0 + If ResetExpectations Then _ + Exit Function + + Dim sMsg$: sMsg = "Unrealized expectations: " + Dim info As ExpectationInfo + Do While ids_.Count <> 0 + sMsg = sMsg & vbNewLine & InfoToString(PopExpectation) + Loop + Call Dev_LogMsg(sMsg) +End Function + +Public Function API_UserInteraction_ShowMessage(nMsg&, ParamArray params() As Variant) + Dim iExpected As ExpectationInfo: iExpected = PopExpectation + If iExpected.type_ = T_UI_INVALID Then _ + Call Err.Raise(UNEXPECTED_INTERACTION, Description:="ShowMessage " & nMsg) + + Dim iActual As ExpectationInfo + iActual.type_ = T_UI_MESSAGE + iActual.id_ = nMsg + iActual.response_ = vbNullString + + If Not CompareInfo(iActual, iExpected) Then _ + Call Dev_LogMsg(Fmt("Unrecognized interaction" & vbNewLine & _ + "Expected: {1}" & vbNewLine & _ + "Actual: {2}", _ + InfoToString(iExpected), InfoToString(iActual))) +End Function + +Public Function API_UserInteraction_AskQuestion(nQuestion&, ParamArray params() As Variant) As Boolean + Dim iExpected As ExpectationInfo: iExpected = PopExpectation + If iExpected.type_ = T_UI_INVALID Then _ + Call Err.Raise(UNEXPECTED_INTERACTION, Description:="AskQuestion " & nQuestion) + + Dim iActual As ExpectationInfo + iActual.type_ = T_UI_QUESTION + iActual.id_ = nQuestion + + If Not CompareInfo(iActual, iExpected) Then _ + Call Dev_LogMsg(Fmt("Unrecognized interaction" & vbNewLine & _ + "Expected: {1}" & vbNewLine & _ + "Actual: {2}", _ + InfoToString(iExpected), InfoToString(iActual))) + API_UserInteraction_AskQuestion = iExpected.response_ = "YES" +End Function + +Public Function API_UserInteraction_PromptInput( _ + sPrompt$, _ + Optional sTitle$ = vbNullString, _ + Optional sInitial As Variant) As String + Dim iExpected As ExpectationInfo: iExpected = PopExpectation + If iExpected.type_ = T_UI_INVALID Then _ + Call Err.Raise(UNEXPECTED_INTERACTION, Description:="PromptInput") + + Dim iActual As ExpectationInfo + iActual.type_ = T_UI_PROMPT_INPUT + + If Not CompareInfo(iActual, iExpected) Then _ + Call Dev_LogMsg(Fmt("Unrecognized interaction" & vbNewLine & _ + "Expected: {1}" & vbNewLine & _ + "Actual: {2}", _ + InfoToString(iExpected), InfoToString(iActual))) + API_UserInteraction_PromptInput = iExpected.response_ +End Function + +Public Function API_UserInteraction_PromptFileFilter( _ + sInitialPath$, sDescription$, sFilter$, _ + Optional sTitle$ = "Выберите файл", _ + Optional bNewApplication As Boolean = False) As String + Dim iExpected As ExpectationInfo: iExpected = PopExpectation + If iExpected.type_ = T_UI_INVALID Then _ + Call Err.Raise(UNEXPECTED_INTERACTION, Description:="PromptFileFilter") + + Dim iActual As ExpectationInfo + iActual.type_ = T_UI_PROMPT_FILE + + If Not CompareInfo(iActual, iExpected) Then _ + Call Dev_LogMsg(Fmt("Unrecognized interaction" & vbNewLine & _ + "Expected: {1}" & vbNewLine & _ + "Actual: {2}", _ + InfoToString(iExpected), InfoToString(iActual))) + API_UserInteraction_PromptFileFilter = iExpected.response_ +End Function + +Public Function API_UserInteraction_PromptFile(sInitialPath$, _ + Optional sTitle$ = "Выберите файл", _ + Optional cDescriptions As Collection = Nothing, _ + Optional cFilters As Collection = Nothing, _ + Optional bNewApplication As Boolean = False) As String + Dim iExpected As ExpectationInfo: iExpected = PopExpectation + If iExpected.type_ = T_UI_INVALID Then _ + Call Err.Raise(UNEXPECTED_INTERACTION, Description:="PromptFile") + + Dim iActual As ExpectationInfo + iActual.type_ = T_UI_PROMPT_FILE + + If Not CompareInfo(iActual, iExpected) Then _ + Call Dev_LogMsg(Fmt("Unrecognized interaction" & vbNewLine & _ + "Expected: {1}" & vbNewLine & _ + "Actual: {2}", _ + InfoToString(iExpected), InfoToString(iActual))) + API_UserInteraction_PromptFile = iExpected.response_ +End Function + +Public Function API_UserInteraction_PromptFolder(sInitialPath$, _ + Optional sTitle$ = "Выберите каталог", _ + Optional bNewApplication As Boolean = False) As String + Dim iExpected As ExpectationInfo: iExpected = PopExpectation + If iExpected.type_ = T_UI_INVALID Then _ + Call Err.Raise(UNEXPECTED_INTERACTION, Description:="PromptFile") + + Dim iActual As ExpectationInfo + iActual.type_ = T_UI_PROMPT_FILE + + If Not CompareInfo(iActual, iExpected) Then _ + Call Dev_LogMsg(Fmt("Unrecognized interaction" & vbNewLine & _ + "Expected: {1}" & vbNewLine & _ + "Actual: {2}", _ + InfoToString(iExpected), InfoToString(iActual))) + API_UserInteraction_PromptFolder = iExpected.response_ +End Function + +Public Function API_UserInteraction_FollowHyperlink(oDocument As Object, sAddress$) + Dim iExpected As ExpectationInfo: iExpected = PopExpectation + If iExpected.type_ = T_UI_INVALID Then _ + Call Err.Raise(UNEXPECTED_INTERACTION, Description:="FollowHyperlink") + + Dim iActual As ExpectationInfo + iActual.type_ = T_UI_FOLLOW_HYPERLINK + + If Not CompareInfo(iActual, iExpected) Then _ + Call Dev_LogMsg(Fmt("Unrecognized interaction" & vbNewLine & _ + "Expected: {1}" & vbNewLine & _ + "Actual: {2}", _ + InfoToString(iExpected), InfoToString(iActual))) +End Function + +' ===== +Private Function ResetCollection() + Set ids_ = New Collection + Set types_ = New Collection + Set responses_ = New Collection +End Function + +Private Function AddExpectation(nType As InteractionType, Optional nID& = 0, Optional sResponse$ = vbNullString) + Call types_.Add(nType) + Call ids_.Add(nID) + Call responses_.Add(sResponse) +End Function + +Private Function PopExpectation() As ExpectationInfo + If ids_.Count = 0 Then + PopExpectation.id_ = T_UI_INVALID + Exit Function + End If + + PopExpectation.id_ = ids_.Item(1) + PopExpectation.type_ = types_.Item(1) + PopExpectation.response_ = responses_.Item(1) + + Call ids_.Remove(1) + Call types_.Remove(1) + Call responses_.Remove(1) +End Function + +Private Function InfoToString(target As ExpectationInfo) As String + Select Case target.type_ + Case T_UI_MESSAGE: InfoToString = "Message " & target.id_ + Case T_UI_QUESTION: InfoToString = "Question " & target.id_ + Case T_UI_PROMPT_INPUT: InfoToString = "InputBox with response " & target.response_ + Case T_UI_PROMPT_FILE: InfoToString = "FilePromp with response " & target.response_ + Case T_UI_FOLLOW_HYPERLINK: InfoToString = "Follow hyperlink " & target.response_ + End Select +End Function + +Private Function CompareInfo(val1 As ExpectationInfo, val2 As ExpectationInfo) As Boolean + CompareInfo = False + If val1.id_ <> val2.id_ Then _ + Exit Function + If val1.type_ <> val2.type_ Then _ + Exit Function + CompareInfo = True +End Function diff --git a/dev/API_TestRunner.cls b/dev/API_TestRunner.cls new file mode 100644 index 0000000..5fc2b49 --- /dev/null +++ b/dev/API_TestRunner.cls @@ -0,0 +1,119 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "API_TestRunner" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'================ VBA tests runner ============= +' Shared module version: 20220410 +' Depends on: DevTester, DevTools, DataTools, API_Logger, CDS_InfoTests, CDS_InfoFunction, API_Timer +' Required reference: Scripting, VBIDE, Word, Excel, Visio +Option Explicit + +Public testsDB_ As Scripting.Dictionary ' Value = Collection of tests +Private target_ As Object ' Wrapper +Private logger_ As API_Logger +Private timer_ As API_Timer + +' Sink object should implement function PushTestResult(sSuite$, sTest$, bResult As Boolean, sMsg$, dDuration as Double) +Private sink_ As Object + +Private Sub Class_Initialize() + Set timer_ = New API_Timer +End Sub + +Private Sub Class_Terminate() + Set target_ = Nothing +End Sub + +Public Function Init(targetWrapper As Object, oLog As API_Logger, Optional oSink As Object = Nothing) + Set target_ = targetWrapper + Set logger_ = oLog + Set sink_ = oSink + Set testsDB_ = New Scripting.Dictionary +End Function + +Public Function ScanTests() As Boolean + On Error GoTo RETURN_FALSE + + Call logger_.Log("Scanning for tests...") + Dim nCount&: nCount = Dev_ScanTests(target_.Document.VBProject, testsDB_) + ScanTests = True + Call logger_.Log("Found tests: " & nCount) + Exit Function + +RETURN_FALSE: + ScanTests = False + Call logger_.Log("Failed to scan tests. Error code " & Err.Number & ":" & Err.Description) +End Function + +Public Function RunAllTests() As CDS_InfoTests + If Not ScanTests Then _ + Exit Function + + Dim iResult As New CDS_InfoTests + Dim sSuite As Variant + Dim tests As Collection + For Each sSuite In testsDB_ + Set tests = testsDB_(sSuite) + Dim sTest As Variant + For Each sTest In tests + Call iResult.AddTest(RunTest(CStr(sSuite), CStr(sTest))) + Next sTest + Next sSuite + + Set RunAllTests = iResult +End Function + +Public Function RunTest(sSuite$, sTest$) As Boolean + RunTest = False + + Call timer_.Start + On Error GoTo CANNOT_RUN + Dim sMsg$: sMsg = RunInternal(sSuite, sTest) + On Error GoTo 0 + + RunTest = sMsg = "OK" + If Not sink_ Is Nothing Then _ + Call sink_.PushTestResult(sSuite, sTest, RunTest, sMsg, timer_.TimeElapsed) + Call logger_.Log(sSuite & "." & sTest & " ... " & sMsg) + + Exit Function +CANNOT_RUN: + Call logger_.Log(sSuite & "." & sTest & " ... " & "Failed to run the test") +End Function + +' ===== +Private Function RunInternal(sSuite$, sTest$) As String + If TypeOf target_.Application Is Visio.Application Then + RunInternal = RunFileIO(sSuite, sTest) + Else + RunInternal = target_.Run("DevTester.Dev_RunTest", sSuite, sTest) + End If +End Function + +Private Function RunFileIO(sSuite$, sTest$) As String + Const UTF16_MODE = TristateTrue + + Dim sFileName$: sFileName = target_.Document.Name & "_IO.txt" + Dim sPath$: sPath = target_.Document.Path & sFileName + + Dim fso As New Scripting.FileSystemObject + If fso.FileExists(sPath) Then _ + Call fso.DeleteFile(sPath) + + Call target_.Run("Dev_RunTestFileIO", sSuite, sTest, sFileName) + + If Not fso.FileExists(sPath) Then + Call logger_.Log(sSuite & "." & sTest & " ... " & "Failed to run the test") + Exit Function + End If + + Dim fs As Scripting.TextStream: Set fs = fso.OpenTextFile(sPath, ForReading, Format:=UTF16_MODE) + RunFileIO = fs.ReadAll + Call fs.Close + Call fso.DeleteFile(sPath) +End Function diff --git a/dev/CDS_InfoFunction.cls b/dev/CDS_InfoFunction.cls new file mode 100644 index 0000000..87ccc60 --- /dev/null +++ b/dev/CDS_InfoFunction.cls @@ -0,0 +1,16 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "CDS_InfoFunction" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'============ Function info ============ +' Shared module version: 20210220 +Option Explicit + +Public name_ As String +Public type_ As VBIDE.vbext_ProcKind +Public isPublic_ As Boolean diff --git a/dev/CDS_InfoTests.cls b/dev/CDS_InfoTests.cls new file mode 100644 index 0000000..afec3aa --- /dev/null +++ b/dev/CDS_InfoTests.cls @@ -0,0 +1,33 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "CDS_InfoTests" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'================ Tests summary ============ +' Shared module version: 20210306 +Option Explicit + +Public count_ As Long +Public success_ As Long +Public failed_ As Long + +Public Function AddTest(bResult As Boolean) + count_ = count_ + 1 + If bResult Then + success_ = success_ + 1 + Else + failed_ = failed_ + 1 + End If +End Function + +Public Function MergeStats(iSource As CDS_InfoTests) + If iSource Is Nothing Then _ + Exit Function + count_ = count_ + iSource.count_ + success_ = success_ + iSource.success_ + failed_ = failed_ + iSource.failed_ +End Function diff --git a/dev/DevTester.bas b/dev/DevTester.bas new file mode 100644 index 0000000..3ce9104 --- /dev/null +++ b/dev/DevTester.bas @@ -0,0 +1,679 @@ +Attribute VB_Name = "DevTester" +'================ Developer Testing mechanics ============= +' Shared module version: 20220614 +' Depends on: ex_VBA +' Required reference: Microsoft Scripting Runtime +Option Private Module +Option Explicit + +Private Const ENUM_PARAM_CLASS_MODULE = 2 +Private Const ENUM_PARAM_PROCEDURE = 0 + +Public Enum TTestErrors + ASSERT_FAIL = vbObjectError + 1 + UNEXPECTED_INTERACTION +End Enum + +Private g_TestLog As String +Private g_TestCase As String +Private g_TestClause As String + +Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal nMilliseconds As LongPtr) + +' Run this procedure to add new test suite +Public Sub RunAddTestSuite() + Dim iProject As Object: Set iProject = GetVBProject + + Dim sName$: sName = InputBox("Input suite name s_Suite") + If sName = vbNullString Then _ + Exit Sub + If Not sName Like "s_*" Then + Call MsgBox("Invalid suite name", vbExclamation) + Exit Sub + End If + + Dim aComponent As Object: Set aComponent = FindVBComponent(iProject, sName) + If Not aComponent Is Nothing Then + Call MsgBox("Test suite already exists", vbExclamation) + Exit Sub + End If + + Dim iNewComponent As Object + Set iNewComponent = iProject.VBComponents.Add(ENUM_PARAM_CLASS_MODULE) + iNewComponent.Name = sName + Call iNewComponent.CodeModule.AddFromString(DefaultTestCode) + + Dim iHelper As Object: Set iHelper = FindVBComponent(iProject, "DevHelper").CodeModule + Dim nStart&: nStart = iHelper.ProcStartLine("Dev_GetTestSuite", ENUM_PARAM_PROCEDURE) + Call iHelper.InsertLines(nStart + 3, GetTestSuiteLine(sName)) +End Sub + +Public Function Dev_LogMsg(sMsg$) + If g_TestLog <> vbNullString Then _ + g_TestLog = g_TestLog & vbNewLine + + If g_TestCase <> vbNullString Then + g_TestLog = g_TestLog & "Test case: " & g_TestCase & vbNewLine + g_TestCase = vbNullString + End If + + If g_TestClause <> vbNullString Then + g_TestLog = g_TestLog & "Test clause: " & g_TestClause & vbNewLine + g_TestClause = vbNullString + End If + + g_TestLog = g_TestLog & sMsg +End Function + +Public Function Dev_LogError(nErrID&, Optional sDescription$ = vbNullString) + Select Case nErrID + Case 0 To 512: Call Dev_LogMsg("System error " & nErrID & vbNewLine & sDescription) + Case ASSERT_FAIL: Call Dev_LogMsg("Assertion failed... Aborting test") + Case UNEXPECTED_INTERACTION: Call Dev_LogMsg("Unexpected user interaction ... Aborting test") + Case Else: Call Dev_LogMsg("Unknown error type " & nErrID & vbNewLine & sDescription) + End Select +End Function + +Public Function Dev_RunTestFileIO(sSuite$, sTest$, sOutputFile$) + Const UTF16_MODE = TristateTrue + + Dim sResult$: sResult = Dev_RunTest(sSuite, sTest) + Dim sPath$: sPath = Application.ActiveDocument.Path & sOutputFile + + Dim fso As New Scripting.FileSystemObject + Dim fs As Scripting.TextStream: Set fs = fso.OpenTextFile(sPath, ForWriting, Create:=True, Format:=UTF16_MODE) + + Call fs.Write(sResult) + Call fs.Close +End Function + +Public Function Dev_RunTest(sSuite$, sTest$) As String + Dim iSuite As Object: Set iSuite = Dev_GetTestSuite(sSuite) + If iSuite Is Nothing Then + Dev_RunTest = "Invalid test suite" + Exit Function + End If + + Call Randomize + Call ResetLog + Call ResetDescription + + On Error GoTo ON_ERROR + Call iSuite.Setup + Call CallByName(iSuite, sTest, VbMethod) + Call iSuite.Teardown + On Error GoTo 0 + + Dev_RunTest = IIf(g_TestLog = vbNullString, "OK", "FAILED" & vbNewLine & g_TestLog) + Exit Function + +ON_ERROR: + Call Dev_LogError(Err.Number, Err.Description) + Dev_RunTest = "FAILED" & vbNewLine & g_TestLog + Set iSuite = Nothing +End Function + +Public Function Dev_RunTestDebug(sSuite$, sTest$) As String + Dim iSuite As Object: Set iSuite = Dev_GetTestSuite(sSuite) + If iSuite Is Nothing Then + Dev_RunTestDebug = "Invalid test suite" + Exit Function + End If + + Call ResetLog + Call ResetDescription + + Call iSuite.Setup + Call CallByName(iSuite, sTest, VbMethod) + Call iSuite.Teardown + + Dev_RunTestDebug = IIf(g_TestLog = vbNullString, "OK", "FAILED" & vbNewLine & g_TestLog) +End Function + +' ====== Tester functions ======== +Public Function Dev_NewCase(sDescription$) + Call ResetDescription + g_TestCase = sDescription +End Function + +Public Function Dev_NewClause(sDescription$) + g_TestClause = sDescription +End Function + +Public Function Dev_ExpectObjectValid(oVal As Object, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + Dev_ExpectObjectValid = TestObjectValid(oVal) + If Not Dev_ExpectObjectValid Then _ + Call Dev_LogMsg("Expected valid object") + Call ResetClause +End Function + +Public Function Dev_ExpectObjectInvalid(oVal As Object, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + Dev_ExpectObjectInvalid = Not TestObjectValid(oVal) + If Not Dev_ExpectObjectInvalid Then _ + Call Dev_LogMsg("Expected invalid object") + Call ResetClause +End Function + +Public Function Dev_ExpectNothing(oVal As Object, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + Dev_ExpectNothing = oVal Is Nothing + If Not Dev_ExpectNothing Then _ + Call Dev_LogMsg("Expected Nothing") + Call ResetClause +End Function + +Public Function Dev_ExpectNotNothing(oVal As Object, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + Dev_ExpectNotNothing = Not oVal Is Nothing + If Not Dev_ExpectNotNothing Then _ + Call Dev_LogMsg("Expected not Nothing") + Call ResetClause +End Function + +Public Function Dev_ExpectTrue(bVal As Boolean, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + Dev_ExpectTrue = bVal = True + If Not Dev_ExpectTrue Then _ + Call Dev_LogMsg("Expected TRUE statement") + Call ResetClause +End Function + +Public Function Dev_ExpectFalse(bVal As Boolean, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + Dev_ExpectFalse = bVal = False + If Not Dev_ExpectFalse Then _ + Call Dev_LogMsg("Expected FALSE statement") + Call ResetClause +End Function + +Public Function Dev_ExpectEQ(actualValue As Variant, expectedValue As Variant, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + + On Error GoTo INCOMPARABLE + Dev_ExpectEQ = CompareDeep(expectedValue, actualValue) = 0 + On Error GoTo 0 + + If Not Dev_ExpectEQ Then _ + Call Dev_LogMsg(Fmt("Actual: {1} | Expectedl: {2}", actualValue, expectedValue)) + Call ResetClause + Exit Function + +INCOMPARABLE: + Dev_ExpectEQ = False + Call Dev_LogMsg(Fmt("Invalid comparison: {1} == {2}", actualValue, expectedValue)) +End Function + +Public Function Dev_ExpectNE(val1 As Variant, val2 As Variant, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + + On Error GoTo INCOMPARABLE + Dev_ExpectNE = CompareDeep(val1, val2) <> 0 + On Error GoTo 0 + + If Not Dev_ExpectNE Then _ + Call Dev_LogMsg(Fmt("Unexpected equality: {1} == {2}", val1, val2)) + Call ResetClause + Exit Function + +INCOMPARABLE: + Dev_ExpectNE = False + Call Dev_LogMsg(Fmt("Invalid comparison: {1} <> {2}", val1, val2)) +End Function + +Public Function Dev_ExpectGR(val1 As Variant, val2 As Variant, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + + On Error GoTo INCOMPARABLE + Dev_ExpectGR = CompareDeep(val1, val2) > 0 + On Error GoTo 0 + + If Not Dev_ExpectGR Then _ + Call Dev_LogMsg(Fmt("Expected: {1} > {2}", val1, val2)) + Call ResetClause + Exit Function + +INCOMPARABLE: + Dev_ExpectGR = False + Call Dev_LogMsg(Fmt("Invalid comparison: {1} > {2}", val1, val2)) +End Function + +Public Function Dev_ExpectLS(val1 As Variant, val2 As Variant, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + + On Error GoTo INCOMPARABLE + Dev_ExpectLS = CompareDeep(val1, val2) < 0 + On Error GoTo 0 + + If Not Dev_ExpectLS Then _ + Call Dev_LogMsg(Fmt("Expected: {1} < {2}", val1, val2)) + Call ResetClause + Exit Function + +INCOMPARABLE: + Dev_ExpectLS = False + Call Dev_LogMsg(Fmt("Invalid comparison: {1} < {2}", val1, val2)) +End Function + +Public Function Dev_ExpectGE(val1 As Variant, val2 As Variant, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + + On Error GoTo INCOMPARABLE + Dev_ExpectGE = CompareDeep(val1, val2) >= 0 + On Error GoTo 0 + + If Not Dev_ExpectGE Then _ + Call Dev_LogMsg(Fmt("Expected: {1} >= {2}", val1, val2)) + Call ResetClause + Exit Function + +INCOMPARABLE: + Dev_ExpectGE = False + Call Dev_LogMsg(Fmt("Invalid comparison: {1} >= {2}", val1, val2)) +End Function + +Public Function Dev_ExpectLE(val1 As Variant, val2 As Variant, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + + On Error GoTo INCOMPARABLE + Dev_ExpectLE = CompareDeep(val1, val2) <= 0 + On Error GoTo 0 + + If Not Dev_ExpectLE Then _ + Call Dev_LogMsg(Fmt("Expected: {1} <= {2}", val1, val2)) + Call ResetClause + Exit Function + +INCOMPARABLE: + Dev_ExpectLE = False + Call Dev_LogMsg(Fmt("Invalid comparison: {1} <= {2}", val1, val2)) +End Function + +Public Function Dev_ExpectAEQ(actualValue As Variant, expectedValue As Variant, nPrecision&, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + + On Error GoTo INCOMPARABLE + Dev_ExpectAEQ = CompareApproximate(actualValue, expectedValue, nPrecision) = 0 + On Error GoTo 0 + + If Not Dev_ExpectAEQ Then _ + Call Dev_LogMsg(Fmt("Actual: {1} | Expectedl: {2} | Precision: {3}", actualValue, expectedValue, nPrecision)) + Call ResetClause + Exit Function + +INCOMPARABLE: + Dev_ExpectAEQ = False + Call Dev_LogMsg(Fmt("Invalid comparison: {1} == {2}, precision {3}", actualValue, expectedValue, nPrecision)) +End Function + +Public Function Dev_ExpectANE(val1 As Variant, val2 As Variant, nPrecision&, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + + On Error GoTo INCOMPARABLE + Dev_ExpectANE = CompareApproximate(val1, val2, nPrecision) <> 0 + On Error GoTo 0 + + If Not Dev_ExpectANE Then _ + Call Dev_LogMsg(Fmt("Unexpected equality: {1} == {2}, precision: {3}", val1, val2, nPrecision)) + Call ResetClause + Exit Function + +INCOMPARABLE: + Dev_ExpectANE = False + Call Dev_LogMsg(Fmt("Invalid comparison: {1} <> {2}, precision {3}", val1, val2, nPrecision)) +End Function + +Public Function Dev_ExpectAGR(val1 As Variant, val2 As Variant, nPrecision&, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + + On Error GoTo INCOMPARABLE + Dev_ExpectAGR = CompareApproximate(val1, val2, nPrecision) > 0 + On Error GoTo 0 + + If Not Dev_ExpectAGR Then _ + Call Dev_LogMsg(Fmt("Expected: {1} > {2}, precision {3}", val1, val2, nPrecision)) + Call ResetClause + Exit Function + +INCOMPARABLE: + Dev_ExpectAGR = False + Call Dev_LogMsg(Fmt("Invalid comparison: {1} > {2}, precision {3}", val1, val2, nPrecision)) +End Function + +Public Function Dev_ExpectALS(val1 As Variant, val2 As Variant, nPrecision&, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + + On Error GoTo INCOMPARABLE + Dev_ExpectALS = CompareApproximate(val1, val2, nPrecision) < 0 + On Error GoTo 0 + + If Not Dev_ExpectALS Then _ + Call Dev_LogMsg(Fmt("Expected: {1} < {2}, precision {3}", val1, val2, nPrecision)) + Call ResetClause + Exit Function + +INCOMPARABLE: + Dev_ExpectALS = False + Call Dev_LogMsg(Fmt("Invalid comparison: {1} < {2}, precision {3}", val1, val2, nPrecision)) +End Function + +Public Function Dev_ExpectAGE(val1 As Variant, val2 As Variant, nPrecision&, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + + On Error GoTo INCOMPARABLE + Dev_ExpectAGE = CompareApproximate(val1, val2, nPrecision) >= 0 + On Error GoTo 0 + + If Not Dev_ExpectAGE Then _ + Call Dev_LogMsg(Fmt("Expected: {1} >= {2}, precision {3}", val1, val2, nPrecision)) + Call ResetClause + Exit Function + +INCOMPARABLE: + Dev_ExpectAGE = False + Call Dev_LogMsg(Fmt("Invalid comparison: {1} >= {2}, precision {3}", val1, val2, nPrecision)) +End Function + +Public Function Dev_ExpectALE(val1 As Variant, val2 As Variant, nPrecision&, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + + On Error GoTo INCOMPARABLE + Dev_ExpectALE = CompareApproximate(val1, val2, nPrecision) <= 0 + On Error GoTo 0 + + If Not Dev_ExpectALE Then _ + Call Dev_LogMsg(Fmt("Expected: {1} <= {2}, precision {3}", val1, val2, nPrecision)) + Call ResetClause + Exit Function + +INCOMPARABLE: + Dev_ExpectALE = False + Call Dev_LogMsg(Fmt("Invalid comparison: {1} <= {2}, precision {3}", val1, val2, nPrecision)) +End Function + +' ========= String comparisons =========== +Public Function Dev_ExpectLike(sValue$, sMask$, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + + Dev_ExpectLike = sValue Like sMask + If Not Dev_ExpectLike Then _ + Call Dev_LogMsg(Fmt("Expected: {1} Like {2}", sValue, sMask)) + Call ResetClause +End Function + +Public Function Dev_ExpectNotLike(sValue$, sMask$, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + + Dev_ExpectNotLike = Not sValue Like sMask + If Not Dev_ExpectNotLike Then _ + Call Dev_LogMsg(Fmt("Expected: {1} not Like {2}", sValue, sMask)) + Call ResetClause +End Function + +' ======= Error comparisons =========== +Public Function Dev_ExpectAnyError(Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + Dev_ExpectAnyError = Err.Number <> 0 + If Not Dev_ExpectAnyError Then _ + Call Dev_LogMsg("Expected any Error, but got nothing") + Call ResetClause +End Function + +Public Function Dev_ExpectError(nError&, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + + Dev_ExpectError = Err.Number = nError + If Err.Number = 0 Then + Call Dev_LogMsg(Fmt("Expected Error #{1}, but got no error", nError)) + ElseIf Not Dev_ExpectError Then + Call Dev_LogMsg(Fmt("Expected Error #{1}, actual Error #{2}", nError, Err.Number)) + End If + + Call Err.Clear + Call ResetClause +End Function + +Public Function Dev_ExpectErrorMsg(sDesc$, Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + + Dev_ExpectErrorMsg = Err.Description = sDesc + If Err.Number = 0 Then + Call Dev_LogMsg(Fmt("Expected Error, but got no error")) + ElseIf Not Dev_ExpectErrorMsg Then + Call Dev_LogMsg(Fmt("Expected error msg: #{1}" & vbNewLine & "Actual error message: #{2}", sDesc, Err.Description)) + End If + + Call Err.Clear + Call ResetClause +End Function + +Public Function Dev_ExpectNoError(Optional sClause$ = vbNullString) As Boolean + If sClause <> vbNullString Then _ + Call Dev_NewClause(sClause) + + Dev_ExpectNoError = Err.Number = 0 + If Not Dev_ExpectNoError Then _ + Call Dev_LogMsg(Fmt("Expected no Error, but got Error #{1}", Err.Number)) + + Call Err.Clear + Call ResetClause +End Function + +' =========== Assertion proxies ========== +Public Function Dev_AssertObjectValid(oVal As Object, Optional sClause$ = vbNullString) + If Not Dev_ExpectObjectValid(oVal, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertObjectInvalid(oVal As Object, Optional sClause$ = vbNullString) + If Not Dev_ExpectObjectInvalid(oVal, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertNothing(oVal As Object, Optional sClause$ = vbNullString) + If Not Dev_ExpectNothing(oVal, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertNotNothing(oVal As Object, Optional sClause$ = vbNullString) + If Not Dev_ExpectNotNothing(oVal, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertTrue(bVal As Boolean, Optional sClause$ = vbNullString) + If Not Dev_ExpectTrue(bVal, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertFalse(bVal As Boolean, Optional sClause$ = vbNullString) + If Not Dev_ExpectFalse(bVal, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertEQ(expectedValue As Variant, actualValue As Variant, Optional sClause$ = vbNullString) + If Not Dev_ExpectEQ(expectedValue, actualValue, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertNE(val1 As Variant, val2 As Variant, Optional sClause$ = vbNullString) + If Not Dev_ExpectNE(val1, val2, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertGR(val1 As Variant, val2 As Variant, Optional sClause$ = vbNullString) + If Not Dev_ExpectGR(val1, val2, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertLS(val1 As Variant, val2 As Variant, Optional sClause$ = vbNullString) + If Not Dev_ExpectLS(val1, val2, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertGE(val1 As Variant, val2 As Variant, Optional sClause$ = vbNullString) + If Not Dev_ExpectGE(val1, val2, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertLE(val1 As Variant, val2 As Variant, Optional sClause$ = vbNullString) + If Not Dev_ExpectLE(val1, val2, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertAEQ(expectedValue As Variant, actualValue As Variant, nPrecision&, Optional sClause$ = vbNullString) + If Not Dev_ExpectAEQ(expectedValue, actualValue, nPrecision, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertANE(val1 As Variant, val2 As Variant, nPrecision&, Optional sClause$ = vbNullString) + If Not Dev_ExpectANE(val1, val2, nPrecision, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertAGR(val1 As Variant, val2 As Variant, nPrecision&, Optional sClause$ = vbNullString) + If Not Dev_ExpectAGR(val1, val2, nPrecision, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertALS(val1 As Variant, val2 As Variant, nPrecision&, Optional sClause$ = vbNullString) + If Not Dev_ExpectALS(val1, val2, nPrecision, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertAGE(val1 As Variant, val2 As Variant, nPrecision&, Optional sClause$ = vbNullString) + If Not Dev_ExpectAGE(val1, val2, nPrecision, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertALE(val1 As Variant, val2 As Variant, nPrecision&, Optional sClause$ = vbNullString) + If Not Dev_ExpectALE(val1, val2, nPrecision, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertLike(sValue$, sMask$, Optional sClause$ = vbNullString) As Boolean + If Not Dev_ExpectLike(sValue, sMask, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertNotLike(sValue$, sMask$, Optional sClause$ = vbNullString) As Boolean + If Not Dev_ExpectNotLike(sValue, sMask, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertAnyError(Optional sClause$ = vbNullString) + If Not Dev_ExpectAnyError(sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertError(nError&, Optional sClause$ = vbNullString) As Boolean + If Not Dev_ExpectError(nError, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertErrorMsg(sDesc$, Optional sClause$ = vbNullString) As Boolean + If Not Dev_ExpectErrorMsg(sDesc, sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +Public Function Dev_AssertNoError(Optional sClause$ = vbNullString) As Boolean + If Not Dev_ExpectNoError(sClause) Then _ + Call Err.Raise(ASSERT_FAIL) +End Function + +' ======== +Private Function ResetLog() + g_TestLog = vbNullString +End Function + +Private Function ResetDescription() + g_TestCase = vbNullString + g_TestClause = vbNullString +End Function + +Private Function ResetClause() + g_TestClause = vbNullString +End Function + +Private Function TestObjectValid(target As Object) As Boolean + Call Sleep(100) + + On Error Resume Next + Dim sName$: sName = target.Name + Select Case Err.Number + ' no error + Case 0: TestObjectValid = True + + ' object doesnt not support property + Case 438: TestObjectValid = True + + Case Else: TestObjectValid = False + End Select +End Function + +Private Function GetVBProject() As Object + Dim iApplication As Object: Set iApplication = Application + If Application.Name = "Microsoft Excel" Then + Set GetVBProject = iApplication.ThisWorkbook.VBProject + Else + Set GetVBProject = iApplication.VBE.ActiveVBProject + End If +End Function + +Private Function FindVBComponent(iProject As Object, sName$) As Object + Dim aComponent As Object + For Each aComponent In iProject.VBComponents + If aComponent.Name = sName Then + Set FindVBComponent = aComponent + Exit Function + End If + Next aComponent +End Function + +Private Function DefaultTestCode() As String + DefaultTestCode = _ + "Public Function Setup()" & vbNewLine & _ + " ' Mandatory setup function" & vbNewLine & _ + "End Function" & vbNewLine & _ + vbNewLine & _ + "Public Function Teardown()" & vbNewLine & _ + " ' Mandatory teardown function" & vbNewLine & _ + "End Function" & vbNewLine & _ + vbNewLine & _ + "Public Function t_Init()" & vbNewLine & _ + " On Error GoTo PROPAGATE_ERROR" & vbNewLine & _ + vbNewLine & _ + " Exit Function" & vbNewLine & _ + "PROPAGATE_ERROR:" & vbNewLine & _ + " Call Dev_LogError(Err.Number, Err.Description)" & vbNewLine & _ + "End Function" +End Function + +Private Function GetTestSuiteLine(sName$) As String + GetTestSuiteLine = _ + " Case " & """" & sName & """" & ": " & _ + "Set Dev_GetTestSuite = New " & sName +End Function diff --git a/dev/DevTesterUI.bas b/dev/DevTesterUI.bas new file mode 100644 index 0000000..4ffdc23 --- /dev/null +++ b/dev/DevTesterUI.bas @@ -0,0 +1,21 @@ +Attribute VB_Name = "DevTesterUI" +'================ Developer Testing mechanics for UI testing ============= +' Shared module version: 20210401 +' Depends on: API_MockInteraction, API_UserInteraction, z_UIMessages +' Required reference: +Option Private Module +Option Explicit + +Private g_MockUI As API_MockInteraction + +Public Function Dev_MockUI() As API_MockInteraction + If g_MockUI Is Nothing Then _ + Set g_MockUI = New API_MockInteraction + Call SetUserInteraction(g_MockUI) + Set Dev_MockUI = g_MockUI +End Function + +Public Function Dev_ResetUI() As Boolean + Dev_ResetUI = g_MockUI.ResetExpectations + Call SetUserInteraction(New API_UserInteraction) +End Function diff --git a/dev/DevTools.bas b/dev/DevTools.bas new file mode 100644 index 0000000..3674087 --- /dev/null +++ b/dev/DevTools.bas @@ -0,0 +1,194 @@ +Attribute VB_Name = "DevTools" +'================ Developer Tools ============= +' Shared module version: 20220811 +' Depends on: ex_WinAPI +' Required reference: Scripting, VBIDE +Option Private Module +Option Explicit + +Private Const TEST_SUITE_MASK = "s_*" +Private Const TEST_NAME_MASK = "t_*" +Private Const COMPILATION_DELAY As Long = 250 ' ms + +Public Function CompileVBProject(target As VBIDE.VBProject) As Boolean + Const CONTROL_ID_COMPILE = 578 + Const MSGBOX_CLASS_ID As String = "#32770" + Const MSGBOX_NAME As String = "Microsoft Visual Basic for Applications" + Const WINDOW_MESSAGE_CLOSE As Long = &H10 + + target.VBE.MainWindow.Visible = True + With target.VBComponents(1).CodeModule + Call .CodePane.Show + Call .InsertLines(1, "123") + Call .DeleteLines(1, 1) + End With + + Dim btnCompile As CommandBarControl: Set btnCompile = target.VBE.CommandBars.FindControl(ID:=CONTROL_ID_COMPILE) + If Not btnCompile.Enabled Then + CompileVBProject = False + Exit Function + End If + + Call btnCompile.Execute + + Call Sleep(COMPILATION_DELAY) + + Dim nHwnd&: nHwnd = FindWindow(MSGBOX_CLASS_ID, MSGBOX_NAME) + CompileVBProject = nHwnd = 0 + If Not CompileVBProject Then _ + Call PostMessage(nHwnd, WINDOW_MESSAGE_CLOSE, 0&, 0&) +End Function + +Public Function UpdateVersionStamp(target As VBIDE.VBProject, sVersion$) As Boolean + UpdateVersionStamp = False + + On Error Resume Next + Dim iModule As VBComponent: Set iModule = target.VBComponents("Main") + If iModule Is Nothing Then _ + Exit Function + + Dim iCode As CodeModule: Set iCode = iModule.CodeModule + + Dim nLineStart&: nLineStart = 1 + Dim nLineEnd&: nLineEnd = iCode.CountOfLines + + Dim nColumnStart&: nColumnStart = 1 + Dim nColumnEnd&: nColumnEnd = 255 + + If Not iCode.Find("Public Const PRODUCT_VERSION", nLineStart, nColumnStart, nLineEnd, nColumnEnd) Then _ + Exit Function + Call iCode.ReplaceLine(nLineEnd, "Public Const PRODUCT_VERSION = """ & sVersion & """") + + UpdateVersionStamp = True +End Function + +Public Function PrepareSkeletonFor(target As Object) + On Error Resume Next + Call target.Application.Run("'" & target.Name & "'" & "!Dev_PrepareSkeleton") +End Function + +Public Function ExtractProperties(sLines() As String, ByRef nCurrent&, ByRef oSink As Scripting.Dictionary) + ExtractProperties = False + + Do While nCurrent <= UBound(sLines, 1) + Dim sLine$: sLine = sLines(nCurrent) + nCurrent = nCurrent + 1 + If sLine Like "%%*" Then _ + Exit Do + + Dim nSeparator&: nSeparator = VBA.InStr(1, sLine, "=") + If nSeparator = 0 Then _ + GoTo NEXT_LINE + If VBA.Left(sLine, 1) = "#" Then _ + GoTo NEXT_LINE + + Dim sKey$: sKey = VBA.Trim(VBA.Left(sLine, nSeparator - 1)) + Dim sValue$: sValue = VBA.Trim(Right(sLine, VBA.Len(sLine) - nSeparator)) + If oSink.Exists(sKey) Then _ + Exit Function + Call oSink.Add(sKey, sValue) +NEXT_LINE: + Loop + + ExtractProperties = True +End Function + +Public Function Dev_CountPublicAPI(target As VBIDE.CodeModule) As Long + Dim nLine& + For nLine = 1 To target.CountOfLines Step 1 + If InStr(1, target.Lines(nLine, 1), "Public") <> 0 Then _ + Dev_CountPublicAPI = Dev_CountPublicAPI + 1 + Next nLine +End Function + +Public Function Dev_ScanFunctions(target As VBIDE.CodeModule) As Collection ' of CDS_InfoFunction + Dim cResult As New Collection + + Dim currentFunc As CDS_InfoFunction + Dim lastFunc As New CDS_InfoFunction + Dim nLine& + For nLine = 1 To target.CountOfLines Step 1 + Set currentFunc = ExtractProcedure(target, nLine) + If lastFunc.name_ <> currentFunc.name_ And currentFunc.name_ <> vbNullString Then + currentFunc.isPublic_ = IsPublicFunc(target, currentFunc) + Call cResult.Add(currentFunc) + End If + Set lastFunc = currentFunc + Next nLine + + Set Dev_ScanFunctions = cResult +End Function + +Public Function Dev_ScanTests(target As VBIDE.VBProject, ByRef cTestsDB As Scripting.Dictionary) As Long + Dim nCount&: nCount = 0 + Dim aComponent As VBIDE.VBComponent + Dim iComponents As VBIDE.VBComponents: Set iComponents = target.VBComponents + Dim tests As Collection + For Each aComponent In iComponents + If aComponent.Type <> vbext_ct_ClassModule Then _ + GoTo NEXT_COMPONENT + If Not aComponent.Name Like TEST_SUITE_MASK Then _ + GoTo NEXT_COMPONENT + + Set tests = New Collection + Dim funcs As Collection: Set funcs = Dev_ScanFunctions(aComponent.CodeModule) + Dim aFunc As CDS_InfoFunction + For Each aFunc In funcs + If aFunc.name_ Like TEST_NAME_MASK And aFunc.isPublic_ Then _ + Call tests.Add(aFunc.name_) + Next aFunc + + If tests.Count > 0 Then + Call cTestsDB.Add(aComponent.Name, tests) + nCount = nCount + tests.Count + End If +NEXT_COMPONENT: + Next aComponent + + Set iComponents = Nothing + Set aComponent = Nothing + + Dev_ScanTests = nCount +End Function + +Public Function Dev_RemoveDebugCode(target As VBIDE.VBProject) + Dim selectedComps As New Collection + Dim aComponent As VBIDE.VBComponent + For Each aComponent In target.VBComponents + If Dev_IsTestingModule(aComponent.Name) Then _ + Call selectedComps.Add(aComponent) + Next aComponent + + For Each aComponent In selectedComps + Call target.VBComponents.Remove(aComponent) + Next aComponent +End Function + +Public Function Dev_IsTestingModule(sName$) As Boolean + Dev_IsTestingModule = True + + If sName Like TEST_SUITE_MASK Then _ + Exit Function + If sName Like "DevHelper*" Then _ + Exit Function + If sName Like "DevTester*" Then _ + Exit Function + If sName Like "DevTesterUI*" Then _ + Exit Function + If sName Like "API_MockInteraction*" Then _ + Exit Function + + Dev_IsTestingModule = False +End Function + +' ===== +Private Function ExtractProcedure(target As VBIDE.CodeModule, nLine&) As CDS_InfoFunction + Set ExtractProcedure = New CDS_InfoFunction + ExtractProcedure.name_ = target.ProcOfLine(nLine, ExtractProcedure.type_) +End Function + +Private Function IsPublicFunc(target As VBIDE.CodeModule, func As CDS_InfoFunction) As Boolean + Dim nStart&: nStart = target.ProcBodyLine(func.name_, func.type_) + Dim sTxt$: sTxt = target.Lines(nStart, 1) + IsPublicFunc = InStr(1, sTxt, "Private") = 0 +End Function diff --git a/dev/ex_ConceptOrganization.bas b/dev/ex_ConceptOrganization.bas new file mode 100644 index 0000000..3f3453d --- /dev/null +++ b/dev/ex_ConceptOrganization.bas @@ -0,0 +1,84 @@ +Attribute VB_Name = "ex_ConceptOrganization" +' ======== Concept organization specific functionality ============ +' Shared module version: 20221031 +' Tested in: +' Depends on: +' Required reference: Scripting +Option Private Module +Option Explicit + +Public Enum TProjectType + T_PRJ_LEAD_ACTIVE = 1 + T_PRJ_LEAD_TENTATIVE = 2 + T_PRJ_OUTCOME = 3 + T_PRJ_INCOME = 4 +End Enum + +Public Enum TProjectCategory + T_PCAT_ERR = 0 + T_PCAT_MISC = 1 + T_PCAT_OUTCOME = 2 + T_PCAT_INCOME = 3 +End Enum + +Public Const SERVER_PATH_INCOME = "\\fs1.concept.ru\projects\01 Income-проекты" +Public Const SERVER_PATH_OUTCOME = "\\fs1.concept.ru\projects\02 Outcome-проекты" +Public Const SERVER_PATH_LEAD_ACTIVE = "\\fs1.concept.ru\projects\03 Переговоры Активные" +Public Const SERVER_PATH_LEAD_TENTATIVE = "\\fs1.concept.ru\projects\03 1 Переговоры возможные" + +Public Function CCListProjects(nType As TProjectType) As Scripting.Dictionary + Dim iProjects As New Scripting.Dictionary + Set CCListProjects = iProjects + + Dim sFolder$: sFolder = GetProjectsFolder(nType) + Dim fso As New Scripting.FileSystemObject + If Not fso.FolderExists(sFolder) Then _ + Exit Function + + Dim iSubFolder As Scripting.Folder + For Each iSubFolder In fso.GetFolder(sFolder).SubFolders + If CCTestProjectName(iSubFolder.Name) Then _ + Call iProjects.Add(iSubFolder.Name, ProjectTypeToCategory(nType)) + Next iSubFolder +End Function + +Public Function CCTestProjectName(sProject$) As Boolean + CCTestProjectName = sProject Like "####*" +End Function + +Public Function CCCategoryToString(nType As TProjectCategory) As String + Select Case nType + Case T_PCAT_ERR: CCCategoryToString = "ERR" + Case T_PCAT_INCOME: CCCategoryToString = "I" + Case T_PCAT_OUTCOME: CCCategoryToString = "O" + Case T_PCAT_MISC: CCCategoryToString = "-" + End Select +End Function + +Public Function CCStringToCategory(sType$) As TProjectCategory + Select Case sType + Case "I": CCStringToCategory = T_PCAT_INCOME + Case "O": CCStringToCategory = T_PCAT_OUTCOME + Case "-": CCStringToCategory = T_PCAT_MISC + Case Else: CCStringToCategory = T_PCAT_ERR + End Select +End Function + +' ============ +Private Function GetProjectsFolder(nType As TProjectType) As String + Select Case nType + Case T_PRJ_INCOME: GetProjectsFolder = SERVER_PATH_INCOME + Case T_PRJ_OUTCOME: GetProjectsFolder = SERVER_PATH_OUTCOME + Case T_PRJ_LEAD_ACTIVE: GetProjectsFolder = SERVER_PATH_LEAD_ACTIVE + Case T_PRJ_LEAD_TENTATIVE: GetProjectsFolder = SERVER_PATH_LEAD_TENTATIVE + End Select +End Function + +Private Function ProjectTypeToCategory(nType As TProjectCategory) As TProjectCategory + Select Case nType + Case T_PRJ_INCOME: ProjectTypeToCategory = T_PCAT_INCOME + Case T_PRJ_OUTCOME: ProjectTypeToCategory = T_PCAT_OUTCOME + Case T_PRJ_LEAD_ACTIVE: ProjectTypeToCategory = T_PCAT_OUTCOME + Case T_PRJ_LEAD_TENTATIVE: ProjectTypeToCategory = T_PCAT_OUTCOME + End Select +End Function diff --git a/excel/API_XLRecordsWrapper.cls b/excel/API_XLRecordsWrapper.cls new file mode 100644 index 0000000..74d5eec --- /dev/null +++ b/excel/API_XLRecordsWrapper.cls @@ -0,0 +1,49 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "API_XLRecordsWrapper" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ==== Оболочка для листа Excel как источника записей данных ========= +' Shared module version: 20210329 +' Depends on: +' Required reference: +' Prerequisites: first column should contain data with no empty cells +Option Explicit + +Private data_ As Excel.Worksheet +Private row_ As Long +Private start_ As Long + +Public Function Init(ws As Excel.Worksheet, Optional nStart& = 2) + start_ = nStart + Set data_ = ws + Call MoveStart +End Function + +Public Function MoveStart() + row_ = start_ +End Function + +Public Function IsDone() As Boolean + IsDone = data_.Cells(row_, 1) = vbNullString +End Function + +Public Function MoveNext() As Boolean + MoveNext = Not IsDone + If MoveNext Then _ + row_ = row_ + 1 +End Function + +Public Function MovePrev() As Boolean + MovePrev = row_ > start_ + If MovePrev Then _ + row_ = row_ - 1 +End Function + +Public Function Field(nColumn&) As Excel.Range + Set Field = data_.Cells(row_, nColumn) +End Function diff --git a/excel/ex_Excel.bas b/excel/ex_Excel.bas new file mode 100644 index 0000000..bc1fd95 --- /dev/null +++ b/excel/ex_Excel.bas @@ -0,0 +1,151 @@ +Attribute VB_Name = "ex_Excel" +'================ Дополнительный функционал Excel ============= +' Shared module version: 20220623 +' Tested in: +' Depends on: +' Required reference: Scripting +Option Private Module +Option Explicit + +Public Const XLUTIL_GRAPH_PADDING = 0.1 +Public Const XL_DEFAULT_FIRST_ROW = 2 +Public Const XL_INVALID_ROW = -1 + +Private Const XL_INFINITY_THRESHOLD = 255 + +Public Function XLFirstEmptyCell(iRange As Excel.Range) As Long + Dim nItem&: nItem = 1 + Dim iCell As Excel.Range + For Each iCell In iRange + If iCell = vbNullString Then + XLFirstEmptyCell = nItem + Exit Function + End If + nItem = nItem + 1 + Next iCell + + XLFirstEmptyCell = -1 +End Function + +Public Function XLGetCallerCell() As Excel.Range + On Error GoTo RETURN_NOTHING + If TypeName(Application.Caller) = "Range" Then + Set XLGetCallerCell = Application.Caller + Exit Function + End If + +RETURN_NOTHING: + On Error GoTo 0 + Set XLGetCallerCell = Nothing +End Function + +Public Function XLWorksheetExists(sName$, iWhere As Excel.Workbook) As Boolean + On Error Resume Next + Dim iSheet As Excel.Worksheet + Set iSheet = iWhere.Sheets(sName) + On Error GoTo 0 + XLWorksheetExists = Not iSheet Is Nothing +End Function + +Public Function XLShowAllData(target As Excel.Worksheet, Optional bKeepRows As Boolean = False, Optional bKeepColumns As Boolean = False) + On Error Resume Next + Call target.ShowAllData + On Error GoTo 0 + + If Not bKeepRows Then _ + target.Rows.EntireRow.Hidden = False + If Not bKeepColumns Then _ + target.Columns.EntireColumn.Hidden = False +End Function + +Public Function XLUpdateHyperlink(iCellAnchor As Excel.Range, sAddress$, Optional sSubAddress$ = "") + Call iCellAnchor.Hyperlinks.Delete + If sAddress = vbNullString Then _ + Exit Function + Call iCellAnchor.Hyperlinks.Add(iCellAnchor, sAddress, sSubAddress) +End Function + +Public Function AutoScaleGraphAxis(target As Excel.Chart, tValueRange As Excel.Range) + Dim dMinValue As Double: dMinValue = WorksheetFunction.Min(tValueRange) + Dim dMaxValue As Double: dMaxValue = WorksheetFunction.Max(tValueRange) + If dMaxValue = dMinValue Then _ + Exit Function + + Dim dPrecision&: dPrecision = -(CLng(VBA.Log(dMaxValue - dMinValue) / VBA.Log(10#)) - 1) + + If VBA.Sgn(dMinValue) = VBA.Sgn(dMaxValue) Then + dMinValue = dMinValue * IIf(dMinValue > 0, 1 - XLUTIL_GRAPH_PADDING, 1 + XLUTIL_GRAPH_PADDING) + dMaxValue = dMaxValue * IIf(dMaxValue > 0, 1 + XLUTIL_GRAPH_PADDING, 1 - XLUTIL_GRAPH_PADDING) + dMinValue = WorksheetFunction.Round(dMinValue, dPrecision) + dMaxValue = WorksheetFunction.Round(dMaxValue, dPrecision) + + target.Axes(xlValue, xlPrimary).MinimumScale = dMinValue + target.Axes(xlValue, xlPrimary).MaximumScale = dMaxValue + End If + + If dPrecision > 0 Then + target.Axes(xlValue, xlPrimary).TickLabels.NumberFormat = "# ##0," & VBA.Replace(VBA.Space(dPrecision), " ", "0") + Else + target.Axes(xlValue, xlPrimary).TickLabels.NumberFormat = "# ##0" + End If +End Function + +Public Function XLFindOrCreateID(sID$, nIdColumn&, target As Excel.Worksheet, _ + Optional nFirstRow& = XL_DEFAULT_FIRST_ROW) As Long + ' Note: this function is precise but slow. Consider using Range.Find but beware of filtered cells being ignored + Dim nRow&: nRow = nFirstRow + Dim sTxt$ + Do + sTxt = target.Cells(nRow, nIdColumn) + If sTxt = vbNullString Then _ + Exit Do + If sTxt = sID Then + XLFindOrCreateID = nRow + Exit Function + End If + nRow = nRow + 1 + Loop + target.Cells(nRow, nIdColumn) = sID + XLFindOrCreateID = nRow +End Function + +Public Function XLBruteFindRow(sTarget$, nIdColumn&, wsWhere As Excel.Worksheet, _ + Optional nFirstRow = XL_DEFAULT_FIRST_ROW) As Long + XLBruteFindRow = XL_INVALID_ROW + Dim nRow&: nRow = nFirstRow + Dim sTxt$ + Do + sTxt = wsWhere.Cells(nRow, nIdColumn) + If sTxt = vbNullString Then + Exit Function + ElseIf sTxt = sTarget Then + XLBruteFindRow = nRow + Exit Function + End If + nRow = nRow + 1 + Loop +End Function + +Public Function FlipColumnsOrder(target As Excel.Worksheet, nStart&, nFinish&) + Dim nItem& + For nItem = 0 To nFinish - nStart - 1 Step 1 + Call target.Columns(nStart).Cut + Call target.Columns(nFinish - nItem + 1).Insert + Next nItem +End Function + +Public Function XLForEachNonEmptyCell(target As Excel.Range, oCallback As Object, sFuncName$) + Dim aCell As Excel.Range + Dim blankCount%: blankCount = 0 + For Each aCell In target + If aCell = vbNullString Then + blankCount = blankCount + 1 + If blankCount > XL_INFINITY_THRESHOLD Then _ + Exit Function + Else + blankCount = 0 + Call CallByName(oCallback, sFuncName, VbMethod, aCell) + End If + Next aCell +End Function + diff --git a/parsers/DetectorClassifier.cls b/parsers/DetectorClassifier.cls new file mode 100644 index 0000000..0bab3b5 --- /dev/null +++ b/parsers/DetectorClassifier.cls @@ -0,0 +1,50 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "DetectorClassifier" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Classification entity detector ======= +' Shared module version: 20220615 +' Tested in: +' Depends on: +' Required reference: API_Python, ex_Python +Option Explicit + +Private tags_ As String + +Public Function Init(sTags$) + tags_ = sTags +End Function + +Public Function Test(sText$) As Boolean + If tags_ = vbNullString Then _ + Exit Function + Test = AccessPython.CallFunction(PY_MODULE_TEXT, "extract_entities", Array(sText)) <> Array() +End Function + +Public Function ExtractFragments(sText$) As PC_ParsedData + Dim iData As New PC_ParsedData + + On Error GoTo SKIP_PYTHON + Dim iResult As Variant + iResult = AccessPython.CallFunction(PY_MODULE_TEXT, "extract_entities", Array(sText)) + On Error GoTo 0 + + Dim nItem& + For nItem = LBound(iResult) To UBound(iResult) Step 1 + Dim nStart&: nStart = iResult(nItem, 0) + Dim nEnd&: nEnd = iResult(nItem, 1) + Dim nClass&: nClass = iResult(nItem, 2) + Call iData.AddItem(nStart, nEnd, nClass) + Next nItem + +SKIP_PYTHON: + Set ExtractFragments = iData +End Function + + + diff --git a/parsers/DetectorListWords.cls b/parsers/DetectorListWords.cls new file mode 100644 index 0000000..c315fde --- /dev/null +++ b/parsers/DetectorListWords.cls @@ -0,0 +1,105 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "DetectorListWords" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Single word dictionary detector ======= +' Shared module version: 20220623 +' Tested in: +' Depends on: +' Required reference: ADODB, Scripting +Option Explicit + +Private data_ As Scripting.Dictionary + +Public Function Init(sDictionaryPath$) + Set data_ = New Scripting.Dictionary + + On Error Resume Next + Call LoadFrom(sDictionaryPath) + On Error GoTo 0 +End Function + +Public Function Test(sText$) As Boolean + Test = data_.Exists(VBA.LCase(sText)) +End Function + +Public Function ExtractFragments(sText$) As PC_ParsedData + Dim iData As New PC_ParsedData + + Dim nStart&: nStart = 1 + Dim nLen&: nLen = VBA.Len(sText) + Dim nCur&: nCur = nStart + Do While nCur <= nLen + If IsDelim(VBA.Mid$(sText, nCur, 1)) Then + If nCur > nStart Then _ + If Test(VBA.Mid$(sText, nStart, nCur - nStart)) Then _ + Call iData.AddItem(nStart - 1, nCur - 1) + nStart = nCur + 1 + End If + nCur = nCur + 1 + Loop + + If nCur > nStart Then _ + If Test(VBA.Mid$(sText, nStart, nCur - nStart)) Then _ + Call iData.AddItem(nStart - 1, nCur - 1) + + Set ExtractFragments = iData +End Function + +' ======== +Public Function LoadFrom(sPath$) + Dim adoStream As New ADODB.Stream + adoStream.Charset = "utf-8" + Call adoStream.Open + Call adoStream.LoadFromFile(sPath) + + Dim nLine&: nLine = 1 + Do Until adoStream.EOS + Dim sItem$: sItem = adoStream.ReadText(adReadLine) + If sItem <> "" And Not data_.Exists(sItem) Then _ + Call data_.Add(VBA.LCase(sItem), nLine) + nLine = nLine + 1 + Loop + + Call adoStream.Close +End Function + +' ========== +Private Function IsDelim(sSymbol$) As Boolean + IsDelim = True + If sSymbol = "." Then + Exit Function + ElseIf sSymbol = Chr(13) Then + Exit Function + ElseIf sSymbol = Chr(10) Then + Exit Function + ElseIf sSymbol = "," Then + Exit Function + ElseIf sSymbol = ChrW(&H2013) Then _ + Exit Function + ElseIf sSymbol = ChrW(&H2012) Then _ + Exit Function + ElseIf sSymbol = ChrW(&H2010) Then _ + Exit Function + ElseIf sSymbol = ";" Then + Exit Function + ElseIf sSymbol = " " Then + Exit Function + ElseIf sSymbol = "!" Then + Exit Function + ElseIf sSymbol = ":" Then + Exit Function + ElseIf sSymbol = "?" Then + Exit Function + ElseIf sSymbol = """" Then + Exit Function + ElseIf sSymbol = "Chr(85)" Then + Exit Function + End If + IsDelim = False +End Function diff --git a/parsers/DetectorMorpho.cls b/parsers/DetectorMorpho.cls new file mode 100644 index 0000000..0f652b1 --- /dev/null +++ b/parsers/DetectorMorpho.cls @@ -0,0 +1,47 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "DetectorMorpho" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Morphology expression detector ======= +' Shared module version: 20220613 +' Tested in: +' Depends on: +' Required reference: API_Python, ex_Python +Option Explicit + +Private tags_ As String + +Public Function Init(sTags$) + tags_ = sTags +End Function + +Public Function Test(sText$) As Boolean + If tags_ = vbNullString Then _ + Exit Function + Test = AccessPython.CallFunction(PY_MODULE_TEXT, "parse", Array(sText, tags_)) <> "" +End Function + +Public Function ExtractFragments(sText$) As PC_ParsedData + Dim iData As New PC_ParsedData + + On Error GoTo SKIP_PYTHON + Dim iResult As Variant + iResult = AccessPython.CallFunction(PY_MODULE_TEXT, "match_all_morpho", Array(sText, tags_)) + On Error GoTo 0 + + Dim nItem& + For nItem = LBound(iResult) To UBound(iResult) Step 1 + Dim nStart&: nStart = iResult(nItem, 0) + Dim nEnd&: nEnd = iResult(nItem, 1) + Call iData.AddItem(nStart, nEnd) + Next nItem + +SKIP_PYTHON: + Set ExtractFragments = iData +End Function + diff --git a/parsers/DetectorRegex.cls b/parsers/DetectorRegex.cls new file mode 100644 index 0000000..9c7b247 --- /dev/null +++ b/parsers/DetectorRegex.cls @@ -0,0 +1,42 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "DetectorRegex" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Regular expression based detector ======= +' Shared module version: 20220613 +' Tested in: +' Depends on: +' Required reference: VBScript_RegExp_55 +Option Explicit + +Private regex_ As RegExp + +Public Function Init(theRegex As RegExp) + Set regex_ = theRegex +End Function + +Public Function Test(sText$) As Boolean + Dim matches As Object: Set matches = regex_.Execute(sText) + If matches.Count <> 1 Then _ + Exit Function + Test = matches.Item(0).Length = VBA.Len(sText) +End Function + +Public Function ExtractFragments(sText$) As PC_ParsedData + Dim iData As New PC_ParsedData + + Dim matches As Object: Set matches = regex_.Execute(sText) + Dim nMatch& + For nMatch = 0 To matches.Count - 1 Step 1 + Dim nStart&: nStart = matches.Item(nMatch).FirstIndex + Dim nEnd&: nEnd = nStart + matches.Item(nMatch).Length + Call iData.AddItem(nStart, nEnd) + Next nMatch + + Set ExtractFragments = iData +End Function diff --git a/parsers/ExtractionOptions.cls b/parsers/ExtractionOptions.cls new file mode 100644 index 0000000..46089d2 --- /dev/null +++ b/parsers/ExtractionOptions.cls @@ -0,0 +1,44 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ExtractionOptions" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ================ Параметры извлечения и загрузки данных ========================= +' Shared module version: 20220614 +' Tested in: +' Depends on: ParserDeclarations +' Required reference: +Option Explicit + +Public detector_ As TDetector +Public param_ As String +Public transform_ As String +Public loadCategory_ As Long + +Private Sub Class_Initialize() + detector_ = T_DETECTOR_UNKNOWN + loadCategory_ = 0 +End Sub + +Public Function FromFlatData(iData As Variant) + detector_ = CLng(iData(1)) + param_ = iData(2) + transform_ = iData(3) + loadCategory_ = CLng(iData(4)) +End Function + +Public Function AsFlatData() As String() + Dim iData() As String + ReDim iData(1 To 4) + + iData(1) = detector_ + iData(2) = param_ + iData(3) = transform_ + iData(4) = loadCategory_ + + AsFlatData = iData +End Function diff --git a/parsers/PC_Fragment.cls b/parsers/PC_Fragment.cls new file mode 100644 index 0000000..829a53b --- /dev/null +++ b/parsers/PC_Fragment.cls @@ -0,0 +1,34 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "PC_Fragment" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Положения фрагмента в тексте ======= +' Shared module version: 20210909 +' Tested in: +' Depends on: +' Required reference: +Option Explicit + +Public start_ As Long +Public end_ As Long +Public type_ As Long + +Public Function Init(nStart&, nEnd&, nType&) + start_ = nStart + end_ = nEnd + type_ = nType +End Function + +Public Function Clone() As PC_Fragment + Set Clone = New PC_Fragment + With Clone + .start_ = start_ + .end_ = end_ + .type_ = type_ + End With +End Function diff --git a/parsers/PC_InfoNPA.cls b/parsers/PC_InfoNPA.cls new file mode 100644 index 0000000..ab02f77 --- /dev/null +++ b/parsers/PC_InfoNPA.cls @@ -0,0 +1,58 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "PC_InfoNPA" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Legal document attributes ======= +' Shared module version: 20220614 +' Tested in: +' Depends on: +' Required reference: Scripting +Option Explicit + +Public prefix_ As String +Public date_ As String +Public number_ As String +Public docType_ As String +Public creator_ As String +Public title_ As String +Public titlePrefix_ As String +Public titleDoc_ As String + +Public isTimeBound_ As Boolean + +Private Sub Class_Initialize() + isTimeBound_ = False +End Sub + +Public Function AsCollection() As Collection + Dim iData As New Collection + Call iData.Add(prefix_) + Call iData.Add(docType_) + Call iData.Add(creator_) + Call iData.Add(number_) + Call iData.Add(date_) + Call iData.Add(title_) + Call iData.Add(titlePrefix_) + Call iData.Add(titleDoc_) + Call iData.Add(isTimeBound_) + Set AsCollection = iData +End Function + +Public Function AsDescription() As Scripting.Dictionary + Dim iData As New Scripting.Dictionary + Call iData.Add("префикс", prefix_) + Call iData.Add("тип документа", docType_) + Call iData.Add("выпускающий орган", creator_) + Call iData.Add("номер", number_) + Call iData.Add("дата", date_) + Call iData.Add("название", title_) + Call iData.Add("префикс титула", titlePrefix_) + Call iData.Add("вложенный документ", titleDoc_) + Call iData.Add("срочный", isTimeBound_) + Set AsDescription = iData +End Function diff --git a/parsers/PC_ParsedData.cls b/parsers/PC_ParsedData.cls new file mode 100644 index 0000000..ed2990d --- /dev/null +++ b/parsers/PC_ParsedData.cls @@ -0,0 +1,42 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "PC_ParsedData" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Положения набора фрагментов в тексте ======= +' Shared module version: 20220614 +' Tested in: +' Depends on: PC_Fragment, ParserDeclarations +' Required reference: +Option Explicit + +Public data_ As New Collection + +Public Property Get Count() As Long + Count = data_.Count +End Property + +Public Property Get IsEmpty() As Boolean + IsEmpty = Count = 0 +End Property + +Public Property Get First() As PC_Fragment + If IsEmpty Then _ + Exit Property + Set First = data_.Item(1) +End Property + +Public Property Get Last() As PC_Fragment + If IsEmpty Then _ + Exit Property + Set Last = data_.Item(data_.Count) +End Property + +Public Function AddItem(nStart&, nEnd&, Optional nType& = 0) + Dim newItem As New PC_Fragment: Call newItem.Init(nStart, nEnd, nType) + Call data_.Add(newItem) +End Function diff --git a/parsers/PC_Tools.cls b/parsers/PC_Tools.cls new file mode 100644 index 0000000..42360d5 --- /dev/null +++ b/parsers/PC_Tools.cls @@ -0,0 +1,127 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "PC_Tools" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Доступ к различным парсерам ======= +' Shared module version: 20220801 +' Tested in: +' Depends on: ParserDeclarations, DetectorListWords, DetectorRegex, DetectorMorpho, DetectorClassifier +' Required reference: +Option Explicit + +Public Function Detector(iType As TDetector, sParam$) As Object +' Any Detector implements methods: +' Public Function Test(sText$) As Boolean +' Public Function ExtractFragments(sText$) As PC_ParsedData + Select Case iType + Case TDetector.T_DETECTOR_ACTION: Set Detector = CachedActionDetector + Case TDetector.T_DETECTOR_LIST: Set Detector = CachedDetectorList(sParam) + Case TDetector.T_DETECTOR_REGEX: Set Detector = CachedDetectorRegex(sParam) + Case TDetector.T_DETECTOR_MORPHO: Set Detector = CachedDetectorMorpho(sParam) + Case TDetector.T_DETECTOR_DATE: + Set Detector = New DetectorRegex: Call Detector.Init(GlobalDateRegex) + Case TDetector.T_DETECTOR_NPA: + Set Detector = New DetectorRegex: Call Detector.Init(GlobalNPARegex) + Case TDetector.T_DETECTOR_BASIC_NER: Set Detector = CachedDetectorNER(sParam) + End Select + If Detector Is Nothing Then _ + Call Err.Raise(CUSTOM_ERROR_DEBUG) +End Function + +Public Function Parser(iType As TDetector, sParam$) As Object +' Any Parser implements methods: +' Public Function Test(sText$) As Boolean +' Public Function Parse(sText$) As Boolean +' Public Function GetData() As Collection +' Public Function GetDataDescription() As Scripting.Dictionary +' Public Function Transform(sText$, sParam$) As String + Select Case iType + Case TDetector.T_DETECTOR_ACTION: Set Parser = Nothing + Case TDetector.T_DETECTOR_LIST: Set Parser = Nothing + Case TDetector.T_DETECTOR_REGEX: Set Parser = Nothing + Case TDetector.T_DETECTOR_MORPHO: Set Parser = Nothing + Case TDetector.T_DETECTOR_DATE: Set Parser = CachedParserDate + Case TDetector.T_DETECTOR_NPA: Set Parser = CachedParserNPA + Case TDetector.T_DETECTOR_BASIC_NER: Set Parser = Nothing + End Select +End Function + +' ======== +Private Function CachedActionDetector() As DetectorListWords + Static s_Detector As DetectorListWords + If s_Detector Is Nothing Then + Set s_Detector = New DetectorListWords + Call s_Detector.Init(LOCAL_MODELS & "\" & MODEL_ACTION_VERBS) + End If + Set CachedActionDetector = s_Detector +End Function + +Private Function CachedDetectorList(sParam$) As DetectorListWords + Static s_Param$ + Static s_Detector As DetectorListWords + If s_Detector Is Nothing Or sParam <> s_Param Then + s_Param = sParam + Set s_Detector = New DetectorListWords + Call s_Detector.Init(sParam) + End If + Set CachedDetectorList = s_Detector +End Function + +Private Function CachedDetectorRegex(sParam$) As DetectorRegex + Static s_Regex As RegExp + Static s_Param$ + Static s_Detector As DetectorRegex + If s_Detector Is Nothing Or sParam <> s_Param Then + s_Param = sParam + Set s_Regex = New RegExp + s_Regex.Global = True + s_Regex.Pattern = sParam + + Set s_Detector = New DetectorRegex + Call s_Detector.Init(s_Regex) + End If + Set CachedDetectorRegex = s_Detector +End Function + +Private Function CachedDetectorMorpho(sParam$) As DetectorMorpho + Static s_Param$ + Static s_Detector As DetectorMorpho + If s_Detector Is Nothing Or sParam <> s_Param Then + s_Param = sParam + Set s_Detector = New DetectorMorpho + Call s_Detector.Init(sParam) + End If + Set CachedDetectorMorpho = s_Detector +End Function + +Private Function CachedParserDate() As ParserDate + Static s_Parser As ParserDate + If s_Parser Is Nothing Then + Set s_Parser = New ParserDate + End If + Set CachedParserDate = s_Parser +End Function + +Private Function CachedParserNPA() As ParserNPA + Static s_Parser As ParserNPA + If s_Parser Is Nothing Then + Set s_Parser = New ParserNPA + End If + Set CachedParserNPA = s_Parser +End Function + +Private Function CachedDetectorNER(sParam$) As DetectorClassifier + Static s_Param$ + Static s_Detector As DetectorClassifier + If s_Detector Is Nothing Or sParam <> s_Param Then + s_Param = sParam + Set s_Detector = New DetectorClassifier + Call s_Detector.Init(sParam) + End If + Set CachedDetectorNER = s_Detector +End Function diff --git a/parsers/ParserDate.cls b/parsers/ParserDate.cls new file mode 100644 index 0000000..5942c06 --- /dev/null +++ b/parsers/ParserDate.cls @@ -0,0 +1,151 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ParserDate" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ========= Date parser ========== +' Shared module version: 20220614 +' Tested in: TestCommons +' Depends on: z_ParserRegex +' Required reference: VBScript_RegExp_55 +Option Explicit + +Private rxDate_ As RegExp + +Public day_ As Integer +Public month_ As Integer +Public year_ As Integer + +Private Sub Class_Initialize() + Set rxDate_ = New RegExp + rxDate_.Pattern = P_DATE_CAPTURE + rxDate_.Global = False +End Sub + +Public Function Init(aDay%, aMonth%, aYear%) + day_ = aDay + month_ = aMonth + year_ = aYear +End Function + +Public Function Test(target$) As Boolean + Test = rxDate_.Test(target) +End Function + +Public Function Parse(target$) As Boolean + Parse = Test(target) + If Parse Then + Dim matches As Object + Set matches = rxDate_.Execute(target) + If matches.Item(0).SubMatches(0) <> vbNullString Then + day_ = CInt(matches.Item(0).SubMatches(0)) + month_ = ConvertDateText2Int(matches.Item(0).SubMatches(1)) + year_ = CInt(matches.Item(0).SubMatches(2)) + Else + day_ = CInt(matches.Item(0).SubMatches(3)) + month_ = CInt(matches.Item(0).SubMatches(4)) + year_ = CInt(matches.Item(0).SubMatches(5)) + End If + End If +End Function + +Public Function GetData() As Collection + Set GetData = New Collection + Call GetData.Add(year_) + Call GetData.Add(month_) + Call GetData.Add(day_) +End Function + +Public Function GetDataDescription() As Scripting.Dictionary + Dim iData As New Scripting.Dictionary + Call iData.Add("год", year_) + Call iData.Add("месяц", month_) + Call iData.Add("день", day_) + Set GetDataDescription = iData +End Function + +Public Function Transform(sText$, sParam$) As String + If Not Parse(sText) Then + Transform = sText + ElseIf sParam = "1" Then + Transform = AsTextString + ElseIf sParam = "2" Then + Transform = AsDigitsString + Else + Transform = sText + End If +End Function + +Public Property Get IsValidDate() As Boolean + IsValidDate = False + + If month_ > 12 Or month_ < 1 Then _ + Exit Property + If day_ > 31 Or day_ < 1 Then _ + Exit Property + + IsValidDate = IsDate(AsDigitsString) +End Property + +Public Property Get DDate() As Double + If Not IsValidDate Then _ + Exit Function + DDate = DateSerial(year_, month_, day_) +End Property + +Public Function AsDigitsString() As String + AsDigitsString = Format(day_, "00") & "." & Format(month_, "00") & "." & Format(year_, IIf(year_ > 100, "0000", "00")) +End Function + +Public Function AsTextString() As String + If Not IsValidDate Then + AsTextString = "INVALID_DATE" + Else + AsTextString = Format(day_, "00") & " " & MonthStr(month_) & " " & Year(DateSerial(year_, 1, 1)) & " года" + End If +End Function + +' ============ +Private Function ConvertDateText2Int(sMonth$) As Integer + If IsNumeric(sMonth) Then + ConvertDateText2Int = CInt(sMonth) + Exit Function + End If + Select Case sMonth + Case "января": ConvertDateText2Int = 1 + Case "февраля": ConvertDateText2Int = 2 + Case "марта": ConvertDateText2Int = 3 + Case "апреля": ConvertDateText2Int = 4 + Case "мая": ConvertDateText2Int = 5 + Case "июня": ConvertDateText2Int = 6 + Case "июля": ConvertDateText2Int = 7 + Case "августа": ConvertDateText2Int = 8 + Case "сентября": ConvertDateText2Int = 9 + Case "октября": ConvertDateText2Int = 10 + Case "ноября": ConvertDateText2Int = 11 + Case "декабря": ConvertDateText2Int = 12 + Case Else: ConvertDateText2Int = 0 + End Select +End Function + +Private Function MonthStr(nMonth%) As String + Select Case nMonth + Case 1: MonthStr = "января" + Case 2: MonthStr = "февраля" + Case 3: MonthStr = "марта" + Case 4: MonthStr = "апреля" + Case 5: MonthStr = "мая" + Case 6: MonthStr = "июня" + Case 7: MonthStr = "июля" + Case 8: MonthStr = "августа" + Case 9: MonthStr = "сентября" + Case 10: MonthStr = "октября" + Case 11: MonthStr = "ноября" + Case 12: MonthStr = "декабря" + Case Else: MonthStr = "INVALID MONTH" + End Select +End Function diff --git a/parsers/ParserDeclarations.bas b/parsers/ParserDeclarations.bas new file mode 100644 index 0000000..87b62d5 --- /dev/null +++ b/parsers/ParserDeclarations.bas @@ -0,0 +1,54 @@ +Attribute VB_Name = "ParserDeclarations" +' ======== Parser declarations ======== +' Shared module version: 20220614 +' Tested in: +' Depends on: +' Required reference: +Option Private Module +Option Explicit + +Public Const LOCAL_MODELS = "C:\Tools\models" +Public Const MODEL_ACTION_VERBS = "ActionVerbs.txt" + +Public Const CUSTOM_ERROR_DEBUG = 1025 + +Public Enum TDetector + [_First] = 1 + + T_DETECTOR_UNKNOWN = 0 + T_DETECTOR_REGEX = 1 + T_DETECTOR_MORPHO = 2 + T_DETECTOR_LIST = 3 + T_DETECTOR_DATE = 4 + T_DETECTOR_ACTION = 5 + T_DETECTOR_NPA = 6 + T_DETECTOR_BASIC_NER = 7 + + [_Last] = 7 +End Enum + +Public Function DetectorFromStr(sName$) As TDetector + Select Case sName + Case "Дата": DetectorFromStr = T_DETECTOR_DATE + Case "Действие": DetectorFromStr = T_DETECTOR_ACTION + Case "Список слов": DetectorFromStr = T_DETECTOR_LIST + Case "RegExp": DetectorFromStr = T_DETECTOR_REGEX + Case "Морфология": DetectorFromStr = T_DETECTOR_MORPHO + Case "НПА": DetectorFromStr = T_DETECTOR_NPA + Case "Им. сущности": DetectorFromStr = T_DETECTOR_BASIC_NER + Case Else: DetectorFromStr = T_DETECTOR_UNKNOWN + End Select +End Function + +Public Function DetectorToStr(iType As TDetector) As String + Select Case iType + Case T_DETECTOR_UNKNOWN: DetectorToStr = "Неопределенная" + Case T_DETECTOR_DATE: DetectorToStr = "Дата" + Case T_DETECTOR_ACTION: DetectorToStr = "Действие" + Case T_DETECTOR_LIST: DetectorToStr = "Список слов" + Case T_DETECTOR_REGEX: DetectorToStr = "RegExp" + Case T_DETECTOR_MORPHO: DetectorToStr = "Морфология" + Case T_DETECTOR_NPA: DetectorToStr = "НПА" + Case T_DETECTOR_BASIC_NER: DetectorToStr = "Им. сущности" + End Select +End Function diff --git a/parsers/ParserNPA.cls b/parsers/ParserNPA.cls new file mode 100644 index 0000000..a99d1d7 --- /dev/null +++ b/parsers/ParserNPA.cls @@ -0,0 +1,179 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ParserNPA" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Legal document title parser ======= +' Shared module version: 20220614 +' Tested in: +' Depends on: +' Required reference: z_ParserRegex, PC_InfoNPA +Option Explicit + +Private rxTitleFirst_ As RegExp +Private rxTitleLast_ As RegExp +Private rxCreatorPrefix_ As RegExp +Private rxTitle_ As RegExp +Private rxImmediate_ As RegExp + +Public data_ As New PC_InfoNPA + +Private Sub Class_Initialize() + Set rxTitleFirst_ = New RegExp + rxTitleFirst_.Pattern = P_NPA_TITLE_FIRST + rxTitleFirst_.Global = False + + Set rxTitleLast_ = New RegExp + rxTitleLast_.Pattern = P_NPA_PROPS_FIRST + rxTitleLast_.Global = False + + Set rxCreatorPrefix_ = New RegExp + rxCreatorPrefix_.Pattern = P_NPA_DOCTYPE + rxCreatorPrefix_.Global = False + + Set rxTitle_ = New RegExp + rxTitle_.Pattern = P_NPA_COMPOSITE_TITLE + rxTitle_.Global = False + + Set rxImmediate_ = New RegExp + rxImmediate_.Pattern = P_NPA_IMMEDIATE + rxImmediate_.Global = False +End Sub + +Public Function Test(target$) As Boolean + Test = rxTitleLast_.Test(target) + If Not Test Then Test = rxTitleFirst_.Test(target) +End Function + +Public Function Parse(target$) As Boolean + Set data_ = New PC_InfoNPA + Dim matches As Object + Dim isTitleLast As Boolean + isTitleLast = rxTitleLast_.Test(target) + If Not isTitleLast Then + If Not rxTitleFirst_.Test(target) Then + Parse = False + Exit Function + End If + End If + + Parse = True + If isTitleLast Then + Set matches = rxTitleLast_.Execute(target) + data_.prefix_ = matches.Item(0).SubMatches(0) + data_.date_ = matches.Item(0).SubMatches(1) + data_.number_ = Trim(matches.Item(0).SubMatches(2)) + data_.title_ = Trim(matches.Item(0).SubMatches(3)) + Else + Set matches = rxTitleFirst_.Execute(target) + data_.title_ = Trim(matches.Item(0).SubMatches(0)) + data_.prefix_ = Trim(matches.Item(0).SubMatches(1)) + data_.date_ = Trim(matches.Item(0).SubMatches(2)) + data_.number_ = Trim(matches.Item(0).SubMatches(3)) + End If + + Call ParsePrefix + Call ParseTitle +End Function + +Public Function GetData() As Collection + Set GetData = data_.AsCollection() +End Function + +Public Function GetDataDescription() As Scripting.Dictionary + Set GetDataDescription = data_.AsDescription() +End Function + +Public Function Transform(sText$, sParam$) As String + Transform = sText +End Function + +' ======= +Private Function ParsePrefix() + If data_.prefix_ = vbNullString Then _ + Exit Function + If Not rxCreatorPrefix_.Test(data_.prefix_) Then + data_.creator_ = data_.prefix_ + Exit Function + End If + + Dim matches As Object: Set matches = rxCreatorPrefix_.Execute(data_.prefix_) + data_.docType_ = CapitalizeFirstLetter(Trim(matches.Item(0).Value)) + If Len(data_.docType_) <> Len(data_.prefix_) Then _ + data_.creator_ = Trim(Right(data_.prefix_, Len(data_.prefix_) - Len(data_.docType_))) + Call FixTypeCase +End Function + +Private Function ParseTitle() + Dim theTitle$: theTitle = data_.title_ + If theTitle = vbNullString Then _ + Exit Function + + data_.isTimeBound_ = rxImmediate_.Test(theTitle) + + If Not rxTitle_.Test(theTitle) Then _ + Exit Function + + Dim matches As Object: Set matches = rxTitle_.Execute(theTitle) + data_.titlePrefix_ = Trim(matches.Item(0).SubMatches(0)) + data_.titleDoc_ = Trim(matches.Item(0).SubMatches(1)) +End Function + +Private Function FixTypeCase() + If Len(data_.docType_) = 0 Then _ + Exit Function + + Select Case Left(data_.docType_, 1) + Case "Д" + data_.docType_ = Replace(data_.docType_, "Директивы", "Директива") + data_.docType_ = Replace(data_.docType_, "Директивой", "Директива") + data_.docType_ = Replace(data_.docType_, "Директиве", "Директива") + Case "З" + data_.docType_ = Replace(data_.docType_, "Заключением", "Заключение") + data_.docType_ = Replace(data_.docType_, "Заключения", "Заключение") + data_.docType_ = Replace(data_.docType_, "Заключению", "Заключение") + data_.docType_ = Replace(data_.docType_, "Законом", "Закон") + data_.docType_ = Replace(data_.docType_, "Закона", "Закон") + data_.docType_ = Replace(data_.docType_, "Закону", "Закон") + Case "И" + data_.docType_ = Replace(data_.docType_, "Информационного письма", "Информационное письмо") + data_.docType_ = Replace(data_.docType_, "Информационным письмом", "Информационное письмо") + data_.docType_ = Replace(data_.docType_, "Информационному письму", "Информационное письмо") + Case "П" + data_.docType_ = Replace(data_.docType_, "Приказом", "Приказ") + data_.docType_ = Replace(data_.docType_, "Приказа", "Приказ") + data_.docType_ = Replace(data_.docType_, "Приказу", "Приказ") + data_.docType_ = Replace(data_.docType_, "Письмом", "Письмо") + data_.docType_ = Replace(data_.docType_, "Письма", "Письмо") + data_.docType_ = Replace(data_.docType_, "Письму", "Письмо") + Case "Р" + data_.docType_ = Replace(data_.docType_, "Распоряжением", "Распоряжение") + data_.docType_ = Replace(data_.docType_, "Распоряжения", "Распоряжение") + data_.docType_ = Replace(data_.docType_, "Распоряжению", "Распоряжение") + data_.docType_ = Replace(data_.docType_, "Решением", "Решение") + data_.docType_ = Replace(data_.docType_, "Решения", "Решение") + data_.docType_ = Replace(data_.docType_, "Решению", "Решение") + Case "У" + If data_.docType_ = "Указа" Then + data_.docType_ = "Указ" + Else + data_.docType_ = Replace(data_.docType_, "Указом", "Указ") + data_.docType_ = Replace(data_.docType_, "Указу", "Указ") + data_.docType_ = Replace(data_.docType_, "Указания", "Указание") + data_.docType_ = Replace(data_.docType_, "Указанием", "Указание") + data_.docType_ = Replace(data_.docType_, "Указанию", "Указание") + End If + Case "Ф" + data_.docType_ = Replace(data_.docType_, "Федеральным", "Федеральный") + data_.docType_ = Replace(data_.docType_, "Федерального", "Федеральный") + data_.docType_ = Replace(data_.docType_, "Федеральному", "Федеральный") + data_.docType_ = Replace(data_.docType_, "законом", "закон") + data_.docType_ = Replace(data_.docType_, "закона", "закон") + data_.docType_ = Replace(data_.docType_, "закону", "закон") + End Select +End Function + diff --git a/parsers/z_ParserRegex.bas b/parsers/z_ParserRegex.bas new file mode 100644 index 0000000..17ae212 --- /dev/null +++ b/parsers/z_ParserRegex.bas @@ -0,0 +1,232 @@ +Attribute VB_Name = "z_ParserRegex" +' ======== Parser regex masks ======== +' Shared module version: 20210909 +' Tested in: +' Depends on: +' Required reference: +Option Private Module +Option Explicit + +Private Const P_SPACE = "(?:\s+?)" + +Private Const P_QUOTE_OPEN = "[""'«“]" +Private Const P_QUOTE_CLOSE = "[""'»”]" +Private Const P_ANY_SHORTEST = ".*?" +Private Const P_ANY = ".*" + +Private Const P_MONTH_RUS = "(?:января|февраля|марта|апреля|мая|июня|июля|августа|сентября|октября|ноября|декабря)" +Private Const P_MONTH_DIGITS = "[0-1]?\d" +Private Const P_DAY_DIGITS = "[0-3]?\d" +Private Const P_YEAR_LONG = "[1-2]\d\d\d" +Private Const P_YEAR_SHORT = "\d\d" +Private Const P_YEAR_DIGITS = "(?:" & P_YEAR_LONG & "|" & P_YEAR_SHORT & ")" + +Private Const P_DATE_TEXT = _ + "(" & P_DAY_DIGITS & ")" & P_SPACE & _ + "(" & P_MONTH_RUS & ")" & P_SPACE & _ + "(" & P_YEAR_LONG & ")" + +Private Const P_DATE_NUMERIC = _ + "(" & P_DAY_DIGITS & ")" & "\." & _ + "(" & P_MONTH_DIGITS & ")" & "\." & _ + "(" & P_YEAR_DIGITS & ")" + +Private Const P_NPA_PREFIX = "[А-Яа-я][\dА-Яа-яA-Za-z,\-\.""'«»“”\s]+?" +Private Const P_NPA_ID_ELEMENT = "[#N№]" & P_SPACE & "?" & "[\dА-Яа-яA-Za-z_@\.\-\\/]+" +Private Const P_NPA_ID_SEQ = P_NPA_ID_ELEMENT & "(?:," & P_SPACE & P_NPA_ID_ELEMENT & ")*" +Private Const P_NPA_INTRO = _ + "(?:" & _ + "[Пп]риложение к" & "|" & _ + "[Вв] редакции" & "|" & _ + "(?:" & _ + "[Рр]екомендован[аоы]?" & "|" & _ + "(?:" & _ + "[Уу]тв\." & "|" & _ + "[Уу]твержд(?:[её]н|ена|ено|ены)" & _ + ")" & " и введ(?:[её]н|ена|ено|ены) в действие" & "|" & _ + "(?:принят[аоы]? и )?" & _ + "(?:" & _ + "[Уу]тв\." & "|" & _ + "[Уу]твержд(?:[её]н|ена|ено|ены)" & "|" & _ + "одобрен[аоы]?" & "|" & _ + "[Вв]вед(?:[её]н|ена|ено|ены) в действие" & _ + ")" & "|" & _ + "принят[аоы]?" & _ + ")" & "(?: на)?" & _ + ")" + +Private Const P_MASK_DOCTYPE = _ + "(?:" & _ + "[Кк]онституаци[яи]" & "|" & _ + "[Фф]едеральн(?:ый|ым|ого|ому) закон(?:ом|а|у)?" & "|" & _ + "[Фф]едеральн(?:ый|ым|ого|ому) [Кк]онституционн(?:ый|ым|ого|ому)] закон(?:ом|а|у)?" & "|" & _ + "[Зз]акон(?:ом|а|у)?(?: РФ| Российской Федерации)?" & "|" & _ + "[Дд]иректив(?:а|ой|ы|е)" & "|" & _ + P_ANY & "[Кк]одекс(?:ом)?" & P_ANY & "|" & _ + P_ANY & "[Кк]онвенци(?:я|ей|ии)" & "|" & _ + "[Уу]казани(?:ем|е|я|ю)" & "|" & _ + "[Зз]аключени(?:ем|е|я|ю)" & "|" & _ + "[Пп]исьм(?:ом|о|а|у)" & "|" & _ + "[Рр]азъяснени(?:ем|е|я|ю)" & "|" & _ + "[Пп]остановлени(?:ем|е|я|ю)" & "|" & _ + "[Пп]риказ(?:ом|а|у)?" & "|" & _ + "[Уу]каз(?:ом|а|у)?" & "|" & _ + "[Ии]нформационн(?:ое|ым|ого|ому) письм(?:ом|о|а|у)" & "|" & _ + "[Рр]аспоряжени(?:ем|е|я|ю)" & "|" & _ + "[Сс]оглашени(?:ем|е|я|ю)(?: о взаимодействии)?" & "|" & _ + "[Рр]ешени(?:ем|е|я|ю)" & _ + ")" + +Private Const P_NPA_TITLE_PREFIX = _ + "(?:" & _ + "[Оо] введении в действие" & "(?: новой редакции)?" & "|" & _ + "[Оо]б издании и применении" & "|" & _ + "[Оо]б утверждении(?: и(?: о)? введении в действие)?" & _ + " " & _ + ")" + +' ====================================== +' ======== Итоговые выражения ========== +' ====================================== + +' ======= Дата ========== +Public Const P_DATE_NO_CAPTURE = _ + "(?:" & _ + P_DAY_DIGITS & P_SPACE & P_MONTH_RUS & P_SPACE & P_YEAR_LONG & _ + "|" & _ + P_DAY_DIGITS & "\." & P_MONTH_DIGITS & "\." & P_YEAR_DIGITS & _ + ")" & _ + "(?:" & P_SPACE & "?" & "(?:года|г\.|г))?" + +Public Const P_DATE_CAPTURE = _ + "^" & _ + "(?:" & _ + P_DATE_TEXT & "|" & _ + P_DATE_NUMERIC & _ + ")" & _ + "(?:" & P_SPACE & "?" & "(?:года|г\.|г))?" & _ + "$" + +' ====== Название НПА ====== +Public Const P_NPA_SCAN = _ + "(?:" & "\b[Сс]м\." & P_SPACE & ")?" & _ + "(?:" & _ + "\bв редакции " & "|" & _ + "\bв соответствии с " & _ + ")?" & _ + "(" & _ + P_NPA_PREFIX & P_SPACE & "от" & P_SPACE & P_DATE_NO_CAPTURE & P_SPACE & "?" & _ + P_NPA_ID_SEQ & "(?:" & P_SPACE & P_QUOTE_OPEN & P_ANY & P_QUOTE_CLOSE & ")?" & _ + "|" & _ + P_ANY_SHORTEST & _ + "\(" & _ + P_ANY_SHORTEST & P_NPA_INTRO & P_SPACE & P_NPA_PREFIX & _ + "(?:" & P_SPACE & "от" & ")?" & P_SPACE & P_DATE_NO_CAPTURE & _ + "(?:" & P_SPACE & "?" & "(?:" & P_NPA_ID_SEQ & "))?" & P_ANY_SHORTEST & _ + "\)" & _ + ")" + +Public Const P_NPA_PROPS_FIRST = _ + "^" & _ + "(" & P_NPA_PREFIX & ")" & _ + P_SPACE & "от" & P_SPACE & "(" & P_DATE_NO_CAPTURE & ")" & _ + P_SPACE & "?" & "(" & P_NPA_ID_SEQ & ")" & _ + "(?:" & P_SPACE & P_QUOTE_OPEN & "(" & P_ANY & ")" & P_QUOTE_CLOSE & ")?" & _ + P_ANY_SHORTEST & _ + "$" + +Public Const P_NPA_TITLE_FIRST = _ + "^" & _ + "(" & P_ANY_SHORTEST & ")" & _ + "\(" & _ + P_ANY_SHORTEST & P_NPA_INTRO & P_SPACE & _ + "(" & P_NPA_PREFIX & ")" & P_SPACE & _ + "(?:от" & P_SPACE & ")?" & "(" & P_DATE_NO_CAPTURE & ")" & _ + "(?:" & P_SPACE & "?" & "(" & P_NPA_ID_SEQ & "))?" & _ + P_ANY_SHORTEST & _ + "\)" & _ + P_ANY_SHORTEST & _ + "$" + +' ===== Тип документа ========= +Public Const P_NPA_DOCTYPE = "^" & "(" & P_MASK_DOCTYPE & ")" + +' ======== Титул документа ====== +Public Const P_NPA_COMPOSITE_TITLE = _ + "^" & _ + "(" & P_NPA_TITLE_PREFIX & ")" & _ + P_QUOTE_OPEN & "?" & _ + "(" & P_ANY_SHORTEST & ")" & _ + P_QUOTE_CLOSE & "?" & _ + "$" + +' ======== Срочность документа === +Public Const P_NPA_IMMEDIATE = _ + " " & _ + "(?:(?:с|на|в|до) |\()" & _ + "(?:плановый |период |плановый период )?" & _ + P_YEAR_DIGITS & _ + "(?:" & _ + "(?:\-| \- | и | по )" & _ + P_YEAR_DIGITS & _ + ")?" & _ + " " & _ + "(?:год(?:ов|а|ы|ах)?|гг\.|гг|г\.|г)" + +' ======== Static access for compiled regexp ====== +Public Function GlobalDateRegex() As RegExp + Static s_Regex As RegExp + If s_Regex Is Nothing Then + Set s_Regex = New RegExp + s_Regex.Global = True + s_Regex.Pattern = P_DATE_NO_CAPTURE + End If + Set GlobalDateRegex = s_Regex +End Function + +Public Function GlobalNPARegex() As RegExp + Static s_Regex As RegExp + If s_Regex Is Nothing Then + Set s_Regex = New RegExp + s_Regex.Global = True + s_Regex.Pattern = P_NPA_SCAN + End If + Set GlobalNPARegex = s_Regex +End Function + +' ============= Типы документов-определений +' Положен(?:ия|ие|ии) об? +' Поряд(?:ка|ок|ке) +' Правила? +' (?:Административного)?[Рр]егламента?(?: по)? +' Рекомендаци[ий] по +' Стратеги[ия] +' Структур[аы] +' Типово(?:го|ое) положени[яе] об? +' Требований(?:(?:, предъявляемых)? к)? +' Форм[аы]? и порядка +' Форм[аы]? +' Перечень + +' ============ Типы документов-действий +' О внесении изменений в +' О(?: некоторых| неотложных| первоочередных)? мерах по (?:реализации|стимулированию|совершенствованию) +' О мероприятиях по +' О перечне +' О подготовке проекта +' О (подписании|принятии|ратификации) +' О реализации +' О создании(?: и ведении)? +' Об изменении состава +' Об образовании ' чего-либо +' Об объявлении ' Другого документа +' Об организации(?: работы? по)? +' Об осуществлении +' Об усилении ' = cовершенствование? +' Об установлении ' задание значения +' Об определении ' процедура задания значения + +' ========= TODO +' Парсить выделяя органы-акторы +' Private Const P_ANY_SPECIAL_SPACE = "[ \xA0\u1680\u180E\u2000-\u200B\u202F\u205F\u3000\uFEFF]+" + diff --git a/samples/20150923 Таймлайнер.xlsm b/samples/20150923 Таймлайнер.xlsm new file mode 100644 index 0000000..a69254b Binary files /dev/null and b/samples/20150923 Таймлайнер.xlsm differ diff --git a/samples/20180725 Технология разметки.docm b/samples/20180725 Технология разметки.docm new file mode 100644 index 0000000..ad7ed58 Binary files /dev/null and b/samples/20180725 Технология разметки.docm differ diff --git a/samples/20200214 Рерархизатор 3.5.vsdm b/samples/20200214 Рерархизатор 3.5.vsdm new file mode 100644 index 0000000..dacad4b Binary files /dev/null and b/samples/20200214 Рерархизатор 3.5.vsdm differ diff --git a/samples/20200214 Подстановки Visio.xlsm b/samples/20200214 Подстановки Visio.xlsm new file mode 100644 index 0000000..c7748dc Binary files /dev/null and b/samples/20200214 Подстановки Visio.xlsm differ diff --git a/samples/20200225 Блоки_v1.1.vsdm b/samples/20200225 Блоки_v1.1.vsdm new file mode 100644 index 0000000..0e7d46c Binary files /dev/null and b/samples/20200225 Блоки_v1.1.vsdm differ diff --git a/samples/DB_Data_sample.cls b/samples/DB_Data_sample.cls new file mode 100644 index 0000000..a6059ed --- /dev/null +++ b/samples/DB_Data_sample.cls @@ -0,0 +1,57 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "DB_Data_sample" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private data_ As Excel.Worksheet + +Public Function Init(target As Excel.Worksheet) + Set data_ = target +End Function + +Public Property Get Count() As Long + Count = ILast.row_ - IBegin.row_ + 1 +End Property + +Public Function IBegin() As IteratorWorker + Set IBegin = New IteratorWorker + Call IBegin.Init(data_) +End Function + +Public Function ILast() As IteratorWorker + Set ILast = New IteratorWorker + Call ILast.Init(data_) + Call ILast.GoLast +End Function + +Public Function INew() As IteratorWorker + Set INew = New IteratorWorker + Call INew.Init(data_) + Call INew.GoLast + Call INew.Increment +End Function + +Public Function Clear() + Call data_.UsedRange.Offset(1).ClearContents +End Function + +Public Function Contains(sWorkerID$) As Boolean + Contains = Not Access(sWorkerID) Is Nothing +End Function + +Public Function Access(sWorkerID$) As IteratorWorker + Dim iWorker As IteratorWorker: Set iWorker = IBegin + Do While Not iWorker.IsDone + If iWorker.WorkerID = sWorkerID Then + Set Access = iWorker + Exit Function + End If + Call iWorker.Increment + Loop +End Function \ No newline at end of file diff --git a/samples/DevHelper_sample.bas b/samples/DevHelper_sample.bas new file mode 100644 index 0000000..0bf4809 --- /dev/null +++ b/samples/DevHelper_sample.bas @@ -0,0 +1,20 @@ +Attribute VB_Name = "DevHelper_sample" +Option Explicit + +Public Function Dev_PrepareSkeleton() + ' Do nothing +End Function + +Public Sub Dev_ManualRunTest() + Dim sSuite$: sSuite = "s_UndoWrapper" + Dim sTest$: sTest = "t_BasicUndo" + Dim sMsg$: sMsg = Dev_RunTestDebug(sSuite, sTest) + Debug.Print sMsg + Call MsgBox(sMsg) +End Sub + +Public Function Dev_GetTestSuite(sName$) As Object + Select Case sName + Case "s_UndoWrapper": Set Dev_GetTestSuite = New s_UndoWrapper + End Select +End Function diff --git a/samples/Iterator_sample.cls b/samples/Iterator_sample.cls new file mode 100644 index 0000000..f9213e1 --- /dev/null +++ b/samples/Iterator_sample.cls @@ -0,0 +1,81 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Iterator_sample" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public row_ As Long +Private data_ As Excel.Worksheet + +Public Sub Init(target As Excel.Worksheet, Optional tRow& = FIRST_ROW) + Set data_ = target + row_ = tRow +End Sub + +Public Function Increment(Optional inc& = 1) + If row_ + inc > 0 Then _ + row_ = row_ + inc +End Function + +Public Function GoFirst() + row_ = FIRST_ROW +End Function + +Public Function GoLast() + row_ = data_.Columns(S_E_ID).Find(vbNullString, LookAt:=xlWhole).Row - 1 +End Function + +Public Function IsDone() As Boolean + IsDone = data_.Cells(row_, S_E_ID) = vbNullString +End Function + +Public Function RemoveRow() + Call data_.Rows(row_).Delete +End Function + +'===== Propertiy Get ===== +Public Property Get WorkerID() As String + WorkerID = data_.Cells(row_, S_E_ID) +End Property + +Public Property Get WorkerName() As String + WorkerName = data_.Cells(row_, S_E_NAME) +End Property + +Public Property Get Active() As Boolean + Active = data_.Cells(row_, S_E_ACTIVE) = 1 +End Property + +Public Property Get Hours() As Double + Hours = data_.Cells(row_, S_E_HOURS) +End Property + +Public Property Get ReportPath() As String + ReportPath = data_.Cells(row_, S_E_PATH) +End Property + +' ==== Property Let ==== +Public Property Let WorkerID(newVal$) + data_.Cells(row_, S_E_ID) = newVal +End Property + +Public Property Let WorkerName(newVal$) + data_.Cells(row_, S_E_NAME) = newVal +End Property + +Public Property Let Active(newVal As Boolean) + data_.Cells(row_, S_E_ACTIVE) = IIf(newVal, 1, 0) +End Property + +Public Property Let Hours(newVal As Double) + data_.Cells(row_, S_E_HOURS) = newVal +End Property + +Public Property Let ReportPath(newVal$) + data_.Cells(row_, S_E_PATH) = newVal +End Property diff --git a/samples/VBAMake_sample.txt b/samples/VBAMake_sample.txt new file mode 100644 index 0000000..1c284df --- /dev/null +++ b/samples/VBAMake_sample.txt @@ -0,0 +1,31 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact_home, source_home, install_home + +name = +description = +artifact_home = +source_home = +install_home = + +%% +# === Build section === +# Available commands: +# build LOCAL_MANIFEST +# copy LOCAL_SOURCE -> [LOCAL_ARTIFACT] +# save_as LOCAL_ARTIFACT -> LOCAL_ARTIFACT +# run LOCAL_SOURCE.bat <- [PARAMETERS] +# run APPLICATION <- [PARAMETERS] + + + +%% +# === Install section == +# Available commands: +# install LOCAL_ARTIFACT -> [INSTALL_PATH] +# add_template LOCAL_ARTIFACT -> [LOCAL_TEMPLATE] +# run LOCAL_ARTIFACT.bat <- [PARAMETERS] +# run APPLICATION <- [PARAMETERS] + + diff --git a/samples/manifest_sample.txt b/samples/manifest_sample.txt new file mode 100644 index 0000000..db7ea6a --- /dev/null +++ b/samples/manifest_sample.txt @@ -0,0 +1,38 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact + +name = +artifact = + +%% +# === Imports Section === +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SharedHome path + + + +%% +# === Source Code Section == +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SourceHome path + + + +%% +# ===== UI Section ======= +# Pairs of path to UI elements, use " -> " delimiter +# First component is a path relative to SourceHome\ui folders +# Second component is internal path inside project file + + + +%% +# === References Section === +# List dependencies in one of the formats +# global : GLOBAL_NAME +# guid : {REGISTERED_GUID} +# file : PATH_TO_LIBRARY \ No newline at end of file diff --git a/samples/s_Test_sample.cls b/samples/s_Test_sample.cls new file mode 100644 index 0000000..a07bf38 --- /dev/null +++ b/samples/s_Test_sample.cls @@ -0,0 +1,31 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_Test_sample" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ===== Test suite sample ======= +Option Explicit + +Private parser_ As PC_ParserDate + +Public Function Setup() + ' Mandatory setup function + +End Function + +Public Function Teardown() + ' Mandatory teardown function + +End Function + +Public Function t_TestName() + On Error GoTo PROPAGATE_ERROR + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/samples/z_UIMessages_sample.bas b/samples/z_UIMessages_sample.bas new file mode 100644 index 0000000..651f9ae --- /dev/null +++ b/samples/z_UIMessages_sample.bas @@ -0,0 +1,71 @@ +Attribute VB_Name = "z_UIMessages_sample" +' Модуль вывода сообщений и взаимодействия с пользователем +Option Private Module +Option Explicit + +'# Коды сообщений +Public Enum MsgCode + MSG_OK = 0 + + 'EM_DOC_NOT_ADDED + + 'IM_SCAN_MODE + + 'QM_ADD_TITLELINK +End Enum + +Private g_UI As API_UserInteraction + +Public Function UserInteraction() As API_UserInteraction + If g_UI Is Nothing Then _ + Set g_UI = New API_UserInteraction + Set UserInteraction = g_UI +End Function + +Public Function SetUserInteraction(newUI As API_UserInteraction) + Set g_UI = newUI +End Function + +Public Function ProcessErrorMessages(expectedErrors As Scripting.Dictionary) + If Err.Number = 0 Then _ + Exit Function + + ' Call Unload(CSE_ProgressBar) + If Not expectedErrors.Exists(Err.Number) Then _ + Call Err.Raise(Err.Number) + + Select Case Err.Number +' Case EM_LINK_NO_FILE: Call UserInteraction.ShowMessage(Err.Number, Err.Source) + End Select +End Function + +Public Function UIShowMessage(theCode As MsgCode, ParamArray params() As Variant) + Dim unwrapped As Variant: unwrapped = params + unwrapped = FixForwardedParams(unwrapped) + + Select Case theCode + ' Case EM_DOC_NOT_ADDED + ' Call MsgBox("Документ не добавлен в Реестр", vbExclamation) + +' Case IM_SCAN_MODE + ' Call MsgBox("Документ находится в режиме справочника, ссылки не размечаются", vbInformation) + + Case Else + Call MsgBox("Неверный код сообщения", vbCritical) + End Select +End Function + +Public Function UIAskQuestion(theCode As MsgCode, ParamArray params() As Variant) As Boolean + Dim unwrapped As Variant: unwrapped = params + unwrapped = FixForwardedParams(unwrapped) + + Dim answer As Long: answer = vbNo + Select Case theCode + ' Case QM_ADD_TITLELINK + ' answer = MsgBox("Внимание! В первый абзац будет добавлена соответствующая ссылка. Продолжить?", vbYesNo + vbQuestion) + + Case Else + Call MsgBox("Неверный код сообщения", vbCritical) + End Select + UIAskQuestion = answer = vbYes +End Function diff --git a/samples/z_UIRibbon_sample.bas b/samples/z_UIRibbon_sample.bas new file mode 100644 index 0000000..a8f64bf --- /dev/null +++ b/samples/z_UIRibbon_sample.bas @@ -0,0 +1,15 @@ +Attribute VB_Name = "z_UIRibbon_sample" +Option Private Module +Option Explicit + +public Sub OnRibbonBtn(control As IRibbonControl) + Select Case control.ID + Case "GotoLinkBegin": Call CC_GotoLinkBegin + Case "GotoLinkEnd": Call CC_GotoLinkEnd + Case "WidthAdd10": Call CC_WidthAdd10 + Case "WidthSub10": Call CC_WidthSub10 + Case "TopAlignment": Call CC_TopAlignment + Case "LeftAlignment": Call CC_LeftAlignment + Case "ToggleInherited": Call ToggleInherited + End Select +End Sub \ No newline at end of file diff --git a/ui/CSE_ListSelector.frm b/ui/CSE_ListSelector.frm new file mode 100644 index 0000000..b021e76 --- /dev/null +++ b/ui/CSE_ListSelector.frm @@ -0,0 +1,198 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CSE_ListSelector + Caption = "Выбор списка значений" + ClientHeight = 8910.001 + ClientLeft = 45 + ClientTop = 375 + ClientWidth = 8400.001 + OleObjectBlob = "CSE_ListSelector.frx":0000 + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "CSE_ListSelector" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +' =========== List selection dialog ================ +' Shared module version: 20220703 +' Tested in: +' Depends on: ex_MSHook +' Required reference: Scripting +Option Explicit +Option Compare Text + +Private input_ As Excel.ListObject +Private items_() As String +Private selected_ As Scripting.Dictionary +Private isUpdating_ As Boolean + +Public delimiter_ As String +Public isCanceled_ As Boolean + +Private Sub UserForm_Initialize() + isUpdating_ = False + isCanceled_ = True + Call PositionInMiddle +End Sub + +Private Sub UserForm_Finalize() + Call HookDisable +End Sub + +Private Sub UserForm_Activate() + Call HookEnable(Me, "ProcessMouseWheelMovement") +End Sub + +Private Sub UserForm_Deactivate() + Call HookDisable +End Sub + +Public Function Init(iData As Excel.ListObject, Optional bAllowNewItems As Boolean = True) + Set input_ = iData + delimiter_ = TBDelim.Text + + Call ResetSelection + Call ScanInput + Call OnFilter("") + + TBNewItem.Enabled = bAllowNewItems + BtnAddItem.Enabled = bAllowNewItems +End Function + +Public Function GetSelectedStr() As String + Dim sText$: sText = vbNullString + Dim vItem As Variant + For Each vItem In selected_.Keys + If sText <> vbNullString Then _ + sText = sText & delimiter_ + sText = sText & CStr(vItem) + Next vItem + GetSelectedStr = sText +End Function + +' ========== Event handlers ========== +Private Sub OkBtn_Click() + isCanceled_ = False + Call Me.Hide + Call HookDisable +End Sub + +Private Sub CancelBtn_Click() + isCanceled_ = True + Call Me.Hide + Call HookDisable +End Sub + +Private Sub ClearListBtn_Click() + Call ResetSelection + Call OnFilter(TBFilter.Text) +End Sub + +Private Sub TBFilter_Change() + Call OnFilter(TBFilter.Text) +End Sub + +Private Sub TBDelim_Change() + delimiter_ = TBDelim.Text +End Sub + +Private Sub LBItems_Change() + If isUpdating_ Then _ + Exit Sub + + Dim nItem& + For nItem = 0 To LBItems.ListCount - 1 Step 1 + Dim sText$: sText = LBItems.List(nItem) + If LBItems.Selected(nItem) Then + If Not selected_.Exists(sText) Then _ + Call selected_.Add(sText, 0) + Else + If selected_.Exists(sText) Then _ + Call selected_.Remove(sText) + End If + Next nItem +End Sub + +Private Sub BtnAddItem_Click() + Dim sNewItem$: sNewItem = TBNewItem.Text + If sNewItem = vbNullString Then _ + Exit Sub + Dim nItem& + For nItem = LBound(items_) To UBound(items_) Step 1 + If items_(nItem) = sNewItem Then + Call UserInteraction.ShowMessage(EM_ITEM_EXISTS, sNewItem) + Exit Sub + End If + Next nItem + + Dim iRow As Excel.ListRow: Set iRow = input_.ListRows.Add(1) + iRow.Range.Cells(1, 1) = sNewItem + Call ScanInput + Call OnFilter(TBFilter.Text) +End Sub + +' ======= Mouse scrolling for listbox ======== +Public Function ProcessMouseWheelMovement(nDirection&) + If nDirection > 0 Then + If LBItems.TopIndex > 0 Then _ + LBItems.TopIndex = LBItems.TopIndex - 1 + Else + If LBItems.TopIndex < LBItems.ListCount - 1 Then _ + LBItems.TopIndex = LBItems.TopIndex + 1 + End If +End Function + +' ========= +Private Function PositionInMiddle() + Dim nTopOffset&: nTopOffset = (Application.UsableHeight / 2) - (Me.Height / 2) + Dim nLeftOffset&: nLeftOffset = (Application.UsableWidth / 2) - (Me.Width / 2) + + Me.StartUpPosition = 0 + Me.Top = Application.Top + IIf(nTopOffset > 0, nTopOffset, 0) + Me.Left = Application.Left + IIf(nLeftOffset > 0, nLeftOffset, 0) +End Function + +Private Function ScanInput() + ReDim items_(1 To input_.Range.Rows.Count - 1) + Dim nRow& + For nRow = 2 To input_.Range.Rows.Count Step 1 + items_(nRow - 1) = input_.Range.Cells(nRow, 1) + Next nRow +End Function + +Private Function ResetSelection() + Set selected_ = New Scripting.Dictionary + selected_.CompareMode = TextCompare +End Function + +Private Function OnFilter(sFilter$) + Call LBItems.Clear + Dim nItem& + For nItem = LBound(items_) To UBound(items_) Step 1 + If sFilter = vbNullString Or VBA.InStr(1, items_(nItem), sFilter, vbTextCompare) <> 0 Then + Call LBItems.AddItem(items_(nItem)) + End If + Next nItem + Call UpdateSelected + Call UpdateCount +End Function + +Private Function UpdateCount() + TBViewCount.Value = LBItems.ListCount + TBTotalCount.Value = ArraySize(items_) + TBSelectedCount.Value = selected_.Count +End Function + +Private Function UpdateSelected() + isUpdating_ = True + + If LBItems.ListCount = 0 Then _ + Exit Function + + Dim nItem& + For nItem = 0 To LBItems.ListCount - 1 Step 1 + LBItems.Selected(nItem) = selected_.Exists(LBItems.List(nItem)) + Next nItem + + isUpdating_ = False +End Function diff --git a/ui/CSE_ListSelector.frx b/ui/CSE_ListSelector.frx new file mode 100644 index 0000000..340cf19 Binary files /dev/null and b/ui/CSE_ListSelector.frx differ diff --git a/ui/CSE_ProgressBar.frm b/ui/CSE_ProgressBar.frm new file mode 100644 index 0000000..6661b37 --- /dev/null +++ b/ui/CSE_ProgressBar.frm @@ -0,0 +1,329 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CSE_ProgressBar + Caption = "Выполнение процесса" + ClientHeight = 2850 + ClientLeft = 45 + ClientTop = 330 + ClientWidth = 5280 + OleObjectBlob = "CSE_ProgressBar.frx":0000 + ShowModal = 0 'False + StartUpPosition = 2 'CenterScreen +End +Attribute VB_Name = "CSE_ProgressBar" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +' =========== Progress Bar ================ +' Shared module version: 20210827 +' Tested in: +' Depends on: +' Required reference: +Option Explicit + +Private thisWindow_& + +Private isInterrupted_ As Boolean +Private canBeInterrupted_ As Boolean + +Private minA_& +Private maxA_& +Private valueA_& +Private progressA_ As Double + +Private minB_& +Private maxB_& +Private valueB_& +Private progressB_ As Double + +Private tStart_& + +Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long + +'Windows API calls to remove the [x] from the top-right of the form +Private Declare PtrSafe Function FindWindow Lib "user32" _ + Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long +Private Declare PtrSafe Function GetWindowLong Lib "user32" _ + Alias "GetWindowLongA" (ByVal nHwnd As Long, ByVal nIndex As Long) As Long +Private Declare PtrSafe Function SetWindowLong Lib "user32" _ + Alias "SetWindowLongA" (ByVal nHwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long + +'Windows API calls to bring the progress bar form to the front of other modeless forms +Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As Long +Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal nHwnd As Long, ByRef lpdwProcessId As Long) As Long +Private Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal nHwnd As Long) As Long + +Private Const UDATE_RATE = 0.005 ' Частота обновления - каждый 0.5% + +Private Sub UserForm_Initialize() + isInterrupted_ = False + canBeInterrupted_ = False + + minA_ = 0 + maxA_ = 100 + valueA_ = 50 + progressA_ = 50 + + Call Init("Загрузка...") + If Application.Name <> "Microsoft Visio" Then _ + Call PositionInMiddle + Call RemoveCloseButton +End Sub + +Public Function Init(sTitle$, _ + Optional sHeader$ = vbNullString, _ + Optional minVal& = 0, _ + Optional maxVal& = 100, _ + Optional curVal& = 0, _ + Optional canInterrupt As Boolean = False) + canBeInterrupted_ = canInterrupt + btnInterrupt.Visible = canInterrupt + isInterrupted_ = False + + If thisWindow_ = 0 Then + Me.Caption = "VBAProgressBar" + thisWindow_ = FindWindow(vbNullString, Me.Caption) + End If + + tStart_ = GetTickCount() + + minA_ = minVal + maxA_ = maxVal + + minB_ = 0 + maxB_ = 100 + valueB_ = 0 + + Call EnableSecondBar(False) + Me.Title = sTitle + Me.HeaderLbl.Caption = sHeader + Me.DescriptionTB.Text = vbNullString + + Call SetAInternal(curVal, bForceUpdate:=True) +End Function + +Public Function InitSecondBar(Optional minVal& = 0, Optional maxVal& = 100, Optional curVal& = 0) + Call EnableSecondBar(True) + minB_ = minVal + maxB_ = maxVal + Call SetBInternal(curVal, bForceUpdate:=True) +End Function + +Public Function ShowModeless() + Call UpdateBar + Call Me.Show(vbModeless) +End Function + +Private Sub btnInterrupt_Click() + HeaderLbl.Caption = "Инициирована отмена, ожидайте..." + isInterrupted_ = True + + btnInterrupt.Enabled = False + Call RepaintEx +End Sub + +Private Sub UserForm_QueryClose(ByRef nCancelCode As Integer, ByRef nCloseMode As Integer) + If nCloseMode = vbFormControlMenu And canBeInterrupted_ Then _ + nCancelCode = True +End Sub + +' ====== Access ===== +Public Property Get Interrupted() As Boolean + Interrupted = isInterrupted_ +End Property + +Public Property Get Time() As Double + Time = GetTickCount() - tStart_ +End Property + +Public Property Get TimeStr() As String + TimeStr = Format(Time / 1000, "# ##0.##") & " сек" +End Property + +Public Property Get Title() As String + Title = Me.Caption +End Property + +Public Property Get Description() As String + Description = DescriptionTB.Text +End Property + +Public Property Get Header() As String + Header = HeaderLbl.Caption +End Property + +Public Property Get SecondBarEnabled() As Boolean + SecondBarEnabled = FrameSecBar.Visible +End Property + +Public Property Get ValueA() As Long + ValueA = valueA_ +End Property + +Public Property Get MinA() As Long + MinA = minA_ +End Property + +Public Property Get MaxA() As Long + MaxA = maxA_ +End Property + +Public Property Get ProgressA() As Double + If maxA_ = minA_ Then + ProgressA = 100 + Else + ProgressA = VBA.Abs((valueA_ - minA_) / (maxA_ - minA_)) + End If +End Property + +Public Property Get ValueB() As Long + ValueB = valueB_ +End Property + +Public Property Get MinB() As Long + MinB = minB_ +End Property + +Public Property Get MaxB() As Long + MaxB = maxB_ +End Property + +Public Property Get ProgressB() As Double + If maxB_ = minB_ Then + ProgressB = 100 + Else + ProgressB = VBA.Abs((valueB_ - minB_) / (maxB_ - minB_)) + End If +End Property + +' ===== Modify ===== +Public Property Let Title(ByVal newVal$) + Me.Caption = newVal + Call RemoveCloseButton +End Property + +Public Property Let Description(ByVal newVal$) + DescriptionTB.Text = newVal + Call RepaintEx +End Property + +Public Property Let Header(ByVal newVal$) + HeaderLbl.Caption = newVal + Call RepaintEx +End Property + +' ====== Actions === +Public Function IncrementA(Optional delta& = 1) + If Me.Visible Then _ + Call SetAInternal(valueA_ + delta, bForceUpdate:=False) +End Function + +Public Function IncrementB(Optional delta& = 1) + If Me.Visible Then _ + Call SetBInternal(valueB_ + delta, bForceUpdate:=False) +End Function + +Public Function HideSecondBar() + Call EnableSecondBar(False) +End Function + +Public Function SetA(ByVal newVal&, Optional bForceUpdate As Boolean = False) + If Me.Visible Then _ + Call SetAInternal(newVal, bForceUpdate) +End Function + +Public Function SetB(ByVal newVal&, Optional bForceUpdate As Boolean = False) + If Me.Visible Then _ + Call SetBInternal(newVal, bForceUpdate) +End Function + +' ======= +Private Function EnableSecondBar(bEnable As Boolean) + FrameSecBar.Visible = bEnable + Call RepaintEx +End Function + +Private Function PositionInMiddle() + Dim nTopOffset&: nTopOffset = (Application.UsableHeight / 2) - (Me.Height / 2) + Dim nLeftOffset&: nLeftOffset = (Application.UsableWidth / 2) - (Me.Width / 2) + + Me.StartUpPosition = 0 + Me.Top = Application.Top + IIf(nTopOffset > 0, nTopOffset, 0) + Me.Left = Application.Left + IIf(nLeftOffset > 0, nLeftOffset, 0) +End Function + +Private Function SetAInternal(ByVal newVal&, bForceUpdate As Boolean) + valueA_ = newVal + If valueA_ > maxA_ Then _ + valueA_ = maxA_ + If valueA_ < minA_ Then _ + valueA_ = minA_ + Call SetProgressA(Me.ProgressA, bForceUpdate) +End Function + +Private Function SetBInternal(ByVal newVal&, bForceUpdate As Boolean) + valueB_ = newVal + If valueB_ > maxB_ Then _ + valueB_ = maxB_ + If valueB_ < minB_ Then _ + valueB_ = minB_ + Call SetProgressB(Me.ProgressB, bForceUpdate) +End Function + +Private Function SetProgressA(newProgress As Double, bForceUpdate As Boolean) + If Not bForceUpdate And Abs(newProgress - progressA_) < UDATE_RATE Then _ + Exit Function + + progressA_ = newProgress + Call UpdateTime + Call UpdateBar + Call RepaintEx +End Function + +Private Function SetProgressB(newProgress As Double, bForceUpdate) + If Not bForceUpdate And Abs(newProgress - progressB_) < UDATE_RATE Then _ + Exit Function + + progressB_ = newProgress + Call UpdateTime + Call UpdateBar + Call RepaintEx +End Function + +Private Function UpdateBar() + fraInside.Width = VBA.Int(lblBack.Width * progressA_) + lblSecBar.Width = VBA.Int(FrameSecBar.Width * progressB_) + + lblBack.Caption = Format(progressA_, "0%") + lblFront.Caption = Format(progressA_, "0%") +End Function + +Private Function RemoveCloseButton() + Const WS_SYSMENU& = &H80000 + Const GWL_STYLE& = (-16) + Dim lStyle&: lStyle = GetWindowLong(thisWindow_, GWL_STYLE) + If lStyle And WS_SYSMENU > 0 Then _ + Call SetWindowLong(thisWindow_, GWL_STYLE, (lStyle And Not WS_SYSMENU)) +End Function + +Private Function BringToFront() + Dim lFocusThread&: lFocusThread = GetWindowThreadProcessId(GetForegroundWindow(), 0) + Dim lThisThread&: lThisThread = GetWindowThreadProcessId(thisWindow_, 0) + If lFocusThread = lThisThread Then + Call SetForegroundWindow(thisWindow_) + Else + DoEvents + End If +End Function + +Private Function UpdateTime() + TimeLabel.Caption = "Длительность: " & TimeStr() +End Function + +Private Function RepaintEx() + If Me.Visible Then + Call Me.Repaint + ' BringToFront ' Раскомментировать, чтобы окно само всплывало при каждом обновлении (ужасно бесит в фоновом режиме) + End If + DoEvents +End Function diff --git a/ui/CSE_ProgressBar.frx b/ui/CSE_ProgressBar.frx new file mode 100644 index 0000000..53e47c8 Binary files /dev/null and b/ui/CSE_ProgressBar.frx differ diff --git a/ui/Calendar/CSE_Calendar.frm b/ui/Calendar/CSE_Calendar.frm new file mode 100644 index 0000000..333c548 --- /dev/null +++ b/ui/Calendar/CSE_Calendar.frm @@ -0,0 +1,483 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CSE_Calendar + Caption = "Calendar" + ClientHeight = 4455 + ClientLeft = 30 + ClientTop = 390 + ClientWidth = 4440 + OleObjectBlob = "CSE_Calendar.frx":0000 + StartUpPosition = 2 'CenterScreen +End +Attribute VB_Name = "CSE_Calendar" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +' =========== Calendar picker native VBA ================ +' Shared module version: 20210502 +' Dependencies: z_CalendarUI, CSE_CallbackCalendar +Option Explicit + +Private Const GWL_STYLE = -16 +Private Const WS_CAPTION = &HC00000 +Private Const MOUSE_LEFT_BTN = 1 + +Private Const CALENDAR_DAYS_COUNT = 42 +Private Const CALENDAR_WEEKDAY_COUNT = 7 +Private Const CALENDAR_MONTH_COUNT = 12 + +Private Const CALENDAR_YEARS_PER_PAGE = 12 + +Private Type CalendarThemeColors + background_ As Long + foreground_ As Long + curDateBG_ As Long + curDateFG_ As Long + inactiveDates_ As Long +End Type + +Private Enum CalendarMode + CAL_MODE_DAY = 0 + CAL_MODE_MONTH = 1 + CAL_MODE_YEAR = 2 +End Enum + +Private Declare PtrSafe Function FindWindow Lib "user32" _ + Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long +Private Declare PtrSafe Function GetWindowLong Lib "user32" _ + Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long +Private Declare PtrSafe Function SetWindowLong Lib "user32" _ + Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long + +Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As LongPtr + +Public isCancelled_ As Boolean + +Private curDate_ As Long + +Private month_ As Long +Private year_ As Long + +Private mode_ As CalendarMode +Private theme_ As TCalendarTheme +Private colors_ As CalendarThemeColors + +Private firstYear_ As Long +Private lastYear_ As Long + +Private xPos_ As Double +Private yPos_ As Double + +Private callbacks_ As Collection + +Private Sub UserForm_Initialize() + Call ResetBorders + Call HideTitleBar + Call InitLabelCallbacks + + isCancelled_ = True + mode_ = CAL_MODE_DAY + + Call PositionInMiddle + Call SetCurrentDateInternal(Int(Now)) + Call SetTheme(T_CT_LIGHT) +End Sub + +Public Function Init(theDate&, aTheme As TCalendarTheme) + isCancelled_ = True + + Call SetCurrentDateInternal(theDate) + Call ChangeMode(CAL_MODE_DAY) + Call UpdateTitle + Call SetTheme(aTheme) + Call ResetBorders +End Function + +Public Property Get SelectedDate() As Long + SelectedDate = curDate_ +End Property + +Public Property Get Theme() As TCalendarTheme + Theme = theme_ +End Property + +Public Function SetTheme(newValue As TCalendarTheme) + theme_ = newValue + Call UpdateThemeColors + Call RepaintAllColors +End Function + +' ==== Events handlings ====== +Public Function OnDayClicked(cLabel As MSForms.Label) + Call ReturnResult(cLabel.Tag) +End Function + +Public Function OnMonthClicked(cLabel As MSForms.Label) + month_ = TagToMonth(cLabel.Caption) + Call ChangeMode(CAL_MODE_DAY) +End Function + +Public Function OnYearClicked(cLabel As MSForms.Label) + If Len(Trim(cLabel.Caption)) = 0 Then _ + Exit Function + year_ = val(cLabel.Caption) + Call ChangeMode(CAL_MODE_MONTH) +End Function + +Private Sub lblToday_Click() + If mode_ <> CAL_MODE_DAY Then + Call SetCurrentDateInternal(Int(Now)) + Call ChangeMode(CAL_MODE_DAY) + Else + Call ReturnResult(Int(Now)) + End If +End Sub + +Private Sub lblThemes_Click() + If theme_ < TCalendarTheme.[_Last] Then + Call SetTheme(theme_ + 1) + Else + Call SetTheme(TCalendarTheme.[_First]) + End If +End Sub + +Private Sub lblUnload_Click() + isCancelled_ = True + Call Me.Hide +End Sub + +Private Sub btnClose_Click() + If mode_ <> CAL_MODE_DAY Then + Call ChangeMode(mode_ - 1) + Else + isCancelled_ = True + Call Me.Hide + End If +End Sub + +Private Sub lblUP_Click() + Select Case mode_ + Case CAL_MODE_DAY + Call IncrementMonth(-1) + + Case CAL_MODE_MONTH + + Case CAL_MODE_YEAR + lastYear_ = firstYear_ - 1 + firstYear_ = firstYear_ - CALENDAR_YEARS_PER_PAGE + Call RepaintYearsColor + End Select +End Sub + +Private Sub lblDOWN_Click() + Select Case mode_ + Case CAL_MODE_DAY + Call IncrementMonth(1) + + Case CAL_MODE_MONTH + + Case CAL_MODE_YEAR + firstYear_ = lastYear_ + 1 + lastYear_ = lastYear_ + CALENDAR_YEARS_PER_PAGE + Call RepaintYearsColor + End Select +End Sub + +Private Sub UserForm_MouseDown(ByVal nBtn As Integer, ByVal nShift As Integer, ByVal mvX As Single, ByVal mvY As Single) + If nBtn = MOUSE_LEFT_BTN Then + xPos_ = mvX + yPos_ = mvY + End If +End Sub + +Private Sub UserForm_MouseMove(ByVal nBtn As Integer, ByVal nShift As Integer, ByVal mvX As Single, ByVal mvY As Single) + If nBtn And MOUSE_LEFT_BTN Then + Me.Left = Me.Left + (mvX - xPos_) + Me.Top = Me.Top + (mvY - yPos_) + End If +End Sub + +Private Sub Frame1_MouseDown(ByVal nBtn As Integer, ByVal nShift As Integer, ByVal mvX As Single, ByVal mvY As Single) + If nBtn = MOUSE_LEFT_BTN Then + xPos_ = mvX + yPos_ = mvY + End If +End Sub + +Private Sub lblTitleCurMY_Click() +'--> Handles the month to year multipage display + If mode_ = CAL_MODE_YEAR Then _ + Exit Sub + Call ChangeMode(mode_ + 1) +End Sub + +' ========= +Private Function ReturnResult(theDate&) + curDate_ = theDate + isCancelled_ = False + Call Me.Hide +End Function + +Private Function PositionInMiddle() + Dim nTopOffset&: nTopOffset = (Application.UsableHeight / 2) - (Me.Height / 2) + Dim nLeftOffset&: nLeftOffset = (Application.UsableWidth / 2) - (Me.Width / 2) + + Me.StartUpPosition = 0 + Me.Top = Application.Top + IIf(nTopOffset > 0, nTopOffset, 0) + Me.Left = Application.Left + IIf(nLeftOffset > 0, nLeftOffset, 0) +End Function + +Private Function HideTitleBar() + Dim frameHandle As Long: frameHandle = FindWindow(vbNullString, Me.Caption) + Dim windowHandle As Long: windowHandle = GetWindowLong(frameHandle, GWL_STYLE) + windowHandle = windowHandle And (Not WS_CAPTION) + Call SetWindowLong(frameHandle, GWL_STYLE, windowHandle) + Call DrawMenuBar(frameHandle) +End Function + +Private Function ResetBorders() + Dim aLabel As control + For Each aLabel In Me.Controls + If TypeOf aLabel Is MSForms.Label Then _ + aLabel.BorderStyle = fmBorderStyleNone + Next +End Function + +Private Function InitLabelCallbacks() + Dim aControl As control + Dim controlType$ + Set callbacks_ = New Collection + For Each aControl In Me.Controls + If Not TypeOf aControl Is MSForms.Label Then _ + GoTo NEXT_CONTROL + controlType = Left(aControl.Name, 1) + If Not controlType Like "[DMY]" Then _ + GoTo NEXT_CONTROL + Call AddCallback(aControl) +NEXT_CONTROL: + Next aControl + + Call AddCallback(lblUP) + Call AddCallback(lblDOWN) + Call AddCallback(lblThemes) + Call AddCallback(lblUnload) + Call AddCallback(lblTitleCurMY, bUnderline:=True) + Call AddCallback(lblToday, bUnderline:=True) +End Function + +Private Function AddCallback(target As control, Optional bUnderline As Boolean = False) + Dim newCallback As New CSE_CallbackCalendar + Call newCallback.Init(target, bUnderline) + Call callbacks_.Add(newCallback) +End Function + +Private Function SetCurrentDateInternal(theDate&) + curDate_ = theDate + month_ = Month(curDate_) + year_ = Year(curDate_) + Call UpdateDays +End Function + +Private Function IncrementMonth(inc&) + year_ = year_ + ((month_ + inc + CALENDAR_MONTH_COUNT - 1) \ CALENDAR_MONTH_COUNT - 1) + month_ = 1 + ((CALENDAR_MONTH_COUNT + (month_ + inc - 1) Mod CALENDAR_MONTH_COUNT) Mod CALENDAR_MONTH_COUNT) + Call UpdateTitle + Call UpdateDays +End Function + +Private Function ChangeMode(newMode As CalendarMode) + If newMode = mode_ Then _ + Exit Function + + Me.MPmainDisplay.Value = newMode + Call SetArrowsVisibility(newMode <> CAL_MODE_MONTH) + mode_ = newMode + Select Case mode_ + Case CAL_MODE_DAY + Call UpdateDays + + Case CAL_MODE_MONTH + Call RepaintMonthsColors + + Case CAL_MODE_YEAR + lastYear_ = year_ + 1 + firstYear_ = lastYear_ - CALENDAR_YEARS_PER_PAGE + 1 + Call RepaintYearsColor + End Select + Call UpdateTitle +End Function + +Private Function UpdateDays() +'--> Populate the calendar + Dim firstDay&: firstDay = DateSerial(year_, month_, 1) + firstDay = firstDay - Weekday(firstDay, vbMonday) + 1 + Dim lastDay&: lastDay = firstDay + CALENDAR_DAYS_COUNT - 1 + + Dim nItem& + For nItem = 1 To CALENDAR_DAYS_COUNT + With Me.Controls("D" & nItem) + .Caption = Day(firstDay + nItem - 1) + .Tag = firstDay + nItem - 1 + End With + Next nItem + + Call RepaintDaysColors +End Function + +Private Function UpdateTitle() + Select Case mode_ + Case CAL_MODE_DAY + lblTitleCurMY.Caption = Format(DateSerial(year_, month_, 1), "MMMM yyyy") + + Case CAL_MODE_MONTH + lblTitleCurMY.Caption = year_ + + Case CAL_MODE_YEAR + lblTitleCurMY.Caption = firstYear_ & " - " & lastYear_ + End Select +End Function + +Private Function UpdateThemeColors() + With colors_ + Select Case theme_ + Case TCalendarTheme.T_CT_DARK + .background_ = RGB(69, 69, 69) + .foreground_ = RGB(252, 248, 248) + .curDateBG_ = RGB(246, 127, 8) + .curDateFG_ = RGB(0, 0, 0) + .inactiveDates_ = RGB(120, 120, 120) + + Case TCalendarTheme.T_CT_RED + .background_ = RGB(87, 0, 0) + .foreground_ = RGB(203, 146, 146) + .curDateBG_ = RGB(122, 185, 247) + .curDateFG_ = RGB(0, 0, 0) + .inactiveDates_ = RGB(144, 70, 70) + + Case TCalendarTheme.T_CT_BLUE + .background_ = RGB(42, 48, 92) + .foreground_ = RGB(179, 179, 179) + .curDateBG_ = RGB(122, 185, 247) + .curDateFG_ = RGB(0, 0, 0) + .inactiveDates_ = RGB(80, 80, 166) + + Case TCalendarTheme.T_CT_LIGHT + .background_ = RGB(240, 240, 240) + .foreground_ = RGB(0, 0, 0) + .curDateBG_ = RGB(246, 127, 8) + .curDateFG_ = RGB(0, 0, 0) + .inactiveDates_ = RGB(200, 200, 200) + End Select + End With +End Function + +Private Function SetArrowsVisibility(isVisible As Boolean) + lblDOWN.Visible = isVisible + lblUP.Visible = isVisible +End Function + +Private Function TagToMonth(sTag$) As Long + Select Case sTag + Case "JAN": TagToMonth = 1 + Case "FEB": TagToMonth = 2 + Case "MAR": TagToMonth = 3 + Case "APR": TagToMonth = 4 + Case "MAY": TagToMonth = 5 + Case "JUN": TagToMonth = 6 + Case "JUL": TagToMonth = 7 + Case "AUG": TagToMonth = 8 + Case "SEP": TagToMonth = 9 + Case "OCT": TagToMonth = 10 + Case "NOV": TagToMonth = 11 + Case "DEC": TagToMonth = 12 + End Select +End Function + +Private Function RepaintAllColors() + Me.BackColor = colors_.background_ + FrameDay.BackColor = colors_.background_ + FrameMonth.BackColor = colors_.background_ + FrameYr.BackColor = colors_.background_ + + lblToday.ForeColor = colors_.foreground_ + lblToday.BorderColor = colors_.foreground_ + + lblTitleCurMY.ForeColor = colors_.foreground_ + lblTitleCurMY.BorderColor = colors_.foreground_ + + lblUnload.ForeColor = colors_.foreground_ + lblThemes.ForeColor = colors_.foreground_ + + lblUP.ForeColor = colors_.foreground_ + lblDOWN.ForeColor = colors_.foreground_ + + Dim nItem& + For nItem = 1 To CALENDAR_WEEKDAY_COUNT Step 1 + Me.Controls("WD" & nItem).ForeColor = colors_.foreground_ + Next nItem + + Call RepaintDaysColors + Call RepaintMonthsColors + Call RepaintYearsColor +End Function + +Private Function RepaintDaysColors() + Dim nItem& + Dim theDate& + For nItem = 1 To CALENDAR_DAYS_COUNT Step 1 + With Me.Controls("D" & nItem) + theDate = .Tag + .BorderStyle = fmBorderStyleNone + If .Tag = curDate_ Then + .BackStyle = fmBackStyleOpaque + .BackColor = colors_.curDateBG_ + .ForeColor = colors_.curDateFG_ + ElseIf Month(.Tag) = month_ Then + .BackStyle = fmBackStyleTransparent + .BackColor = colors_.background_ + .ForeColor = colors_.foreground_ + Else + .BackStyle = fmBackStyleTransparent + .BackColor = colors_.background_ + .ForeColor = colors_.inactiveDates_ + End If + End With + Next nItem +End Function + +Private Function RepaintMonthsColors() + Dim nMonth& + For nMonth = 1 To CALENDAR_MONTH_COUNT Step 1 + With Me.Controls("M" & nMonth) + .BorderStyle = fmBorderStyleNone + If nMonth = month_ Then + .BackStyle = fmBackStyleOpaque + .BackColor = colors_.curDateBG_ + .ForeColor = colors_.curDateFG_ + Else + .BackStyle = fmBackStyleTransparent + .BackColor = colors_.background_ + .ForeColor = colors_.foreground_ + End If + End With + Next nMonth +End Function + +Private Function RepaintYearsColor() + Dim nYear& + For nYear = 1 To CALENDAR_YEARS_PER_PAGE Step 1 + With Me.Controls("Y" & nYear) + .BorderStyle = fmBorderStyleNone + .Caption = CStr(firstYear_ + nYear - 1) + If nYear + firstYear_ - 1 = year_ Then + .BackStyle = fmBackStyleOpaque + .BackColor = colors_.curDateBG_ + .ForeColor = colors_.curDateFG_ + Else + .BackStyle = fmBackStyleTransparent + .BackColor = colors_.background_ + .ForeColor = colors_.foreground_ + End If + End With + Next nYear +End Function diff --git a/ui/Calendar/CSE_Calendar.frx b/ui/Calendar/CSE_Calendar.frx new file mode 100644 index 0000000..26df348 Binary files /dev/null and b/ui/Calendar/CSE_Calendar.frx differ diff --git a/ui/Calendar/CSE_CallbackCalendar.cls b/ui/Calendar/CSE_CallbackCalendar.cls new file mode 100644 index 0000000..e6acd8e --- /dev/null +++ b/ui/Calendar/CSE_CallbackCalendar.cls @@ -0,0 +1,53 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "CSE_CallbackCalendar" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' =========== Calendar picker native VBA - Label clicks callback ================ +' Shared module version: 20210130 +' Dependencies: z_CalendarUI, CSE_Calendar +Option Explicit + +Private Const CAL_MOVE_MARGIN = 2 + +Public WithEvents control_ As MSForms.Label +Attribute control_.VB_VarHelpID = -1 + +Private underline_ As Boolean + +Public Function Init(aControl As MSForms.Label, Optional bUnderline As Boolean = False) + Set control_ = aControl + underline_ = bUnderline +End Function + +Private Sub control__Click() + Dim controlType$: controlType = Left(control_.Name, 1) + Select Case controlType + Case "D": Call CSE_Calendar.OnDayClicked(control_) + Case "M": Call CSE_Calendar.OnMonthClicked(control_) + Case "Y": Call CSE_Calendar.OnYearClicked(control_) + End Select +End Sub + +Private Sub control__MouseMove(ByVal nBtn As Integer, ByVal nShift As Integer, ByVal mvX As Single, ByVal mvY As Single) + Dim bIsOutside As Boolean: bIsOutside = IsMoveOutside(mvX, mvY) + If underline_ Then + control_.Font.Underline = Not bIsOutside + control_.Font.Bold = Not bIsOutside + Else + control_.BorderStyle = IIf(bIsOutside, fmBorderStyleNone, fmBorderStyleSingle) + End If +End Sub + +' ======= +Private Function IsMoveOutside(mvX As Single, mvY As Single) + IsMoveOutside = _ + mvX >= control_.Width - CAL_MOVE_MARGIN Or _ + mvX <= CAL_MOVE_MARGIN Or _ + mvY <= CAL_MOVE_MARGIN Or _ + mvY >= control_.Height - CAL_MOVE_MARGIN +End Function diff --git a/ui/Calendar/z_CalendarUI.bas b/ui/Calendar/z_CalendarUI.bas new file mode 100644 index 0000000..9ec47ec --- /dev/null +++ b/ui/Calendar/z_CalendarUI.bas @@ -0,0 +1,49 @@ +Attribute VB_Name = "z_CalendarUI" +' =========== Calendar picker native VBA ================ +' Shared module version: 20210123 +' Dependencies: CSE_Calendar, CSE_CallbackCalendar +Option Private Module +Option Explicit + +Public Enum TCalendarTheme + T_CT_INVALID = 0 + [_First] = 1 + + T_CT_DARK = 1 + T_CT_RED = 2 + T_CT_BLUE = 3 + T_CT_LIGHT = 4 + + [_Last] = 4 +End Enum + +Public Function PromptDate(initDate&, Optional ByRef cTheme As TCalendarTheme = T_CT_DARK) As Long + With CSE_Calendar + Call .Init(initDate, cTheme) + Call .Show + If .isCancelled_ Then _ + Exit Function + PromptDate = .SelectedDate + cTheme = .Theme + End With +End Function + +Public Function CalendarTheme2String(eTheme As TCalendarTheme) As String + Select Case eTheme + Case T_CT_DARK: CalendarTheme2String = "DARK" + Case T_CT_RED: CalendarTheme2String = "RED" + Case T_CT_BLUE: CalendarTheme2String = "BLUE" + Case T_CT_LIGHT: CalendarTheme2String = "LIGHT" + Case Else: CalendarTheme2String = "INVALID" + End Select +End Function + +Public Function String2CalendarTheme(sTheme$) As TCalendarTheme + Select Case sTheme + Case "DARK": String2CalendarTheme = T_CT_DARK + Case "RED": String2CalendarTheme = T_CT_RED + Case "BLUE": String2CalendarTheme = T_CT_BLUE + Case "LIGHT": String2CalendarTheme = T_CT_LIGHT + Case Else: String2CalendarTheme = T_CT_INVALID + End Select +End Function diff --git a/ui/ribbonVSO/.rels b/ui/ribbonVSO/.rels new file mode 100644 index 0000000..5bdce8f --- /dev/null +++ b/ui/ribbonVSO/.rels @@ -0,0 +1,2 @@ + + \ No newline at end of file diff --git a/ui/ribbonVSO/customUI1.xml b/ui/ribbonVSO/customUI1.xml new file mode 100644 index 0000000..c90030d --- /dev/null +++ b/ui/ribbonVSO/customUI1.xml @@ -0,0 +1,16 @@ +п»ї + + + + + +