From 3ddd8a3c1296862d97924fcf1d30b5a96055e773 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Sun, 29 Jun 2025 17:08:32 +0200 Subject: [PATCH 01/13] refactoring: split reader from dict to implement different readers + minor fixes --- .gitignore | 4 + source/forms/DeclarationDictApiDialog.cls | 2 +- source/modules/CodeModulGenerator.cls | 2 +- .../modules/CodemoduleDeclarationReader.cls | 225 ++++++++++++++++++ source/modules/DeclarationDict.cls | 223 +---------------- source/modules/FileTools.bas | 6 +- source/modules/_AddInAPI.bas | 83 ++++--- source/vcs-options.json | 2 +- 8 files changed, 288 insertions(+), 259 deletions(-) create mode 100644 source/modules/CodemoduleDeclarationReader.cls diff --git a/.gitignore b/.gitignore index fe82cce..38de702 100644 --- a/.gitignore +++ b/.gitignore @@ -21,3 +21,7 @@ vcs-index.json # Ignore log files generated by the VCS Add-in # Comment out the following line if you wish to include log files in git. *.log + +# others +*.dll +*.zip \ No newline at end of file diff --git a/source/forms/DeclarationDictApiDialog.cls b/source/forms/DeclarationDictApiDialog.cls index bd46d20..d14bec7 100644 --- a/source/forms/DeclarationDictApiDialog.cls +++ b/source/forms/DeclarationDictApiDialog.cls @@ -203,7 +203,7 @@ Private Sub RefreshDiffData() Else With Me.lbDictData Set .Recordset = m_WordListRecordset - .Value = Me.lbDictData.Column(0, 0) + .Value = .Column(0, Abs(.ColumnHeads)) End With FillWordVariationsList End If diff --git a/source/modules/CodeModulGenerator.cls b/source/modules/CodeModulGenerator.cls index 60eace2..aa99f4a 100644 --- a/source/modules/CodeModulGenerator.cls +++ b/source/modules/CodeModulGenerator.cls @@ -7,7 +7,7 @@ Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False -Option Compare Database +Option Compare Text Option Explicit Private m_VBComponent As VBComponent diff --git a/source/modules/CodemoduleDeclarationReader.cls b/source/modules/CodemoduleDeclarationReader.cls new file mode 100644 index 0000000..e2245d2 --- /dev/null +++ b/source/modules/CodemoduleDeclarationReader.cls @@ -0,0 +1,225 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "CodemoduleDeclarationReader" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Compare Text +Option Explicit + +Private m_DeclDict As DeclarationDict + +Public Sub ImportVBProject(ByVal VBProject2Import As VBProject, ByVal DeclDict As DeclarationDict) + + Dim vbc As VBComponent + + For Each vbc In VBProject2Import.VBComponents + ImportVBComponent vbc, DeclDict + Next + +End Sub + +Public Sub ImportVBComponent(ByVal VBComponent2Import As VBComponent, ByVal DeclDict As DeclarationDict) + ImportCodeModule VBComponent2Import.CodeModule, DeclDict +End Sub + +Public Sub ImportCodeModule(ByVal CodeModule2Import As CodeModule, ByVal DeclDict As DeclarationDict) + If CodeModule2Import.CountOfLines > 0 Then + ImportCode CodeModule2Import.Lines(1, CodeModule2Import.CountOfLines), DeclDict + End If +End Sub + +Public Sub ImportCode(ByVal Code As String, ByVal DeclDict As DeclarationDict) + + Dim RegEx As RegExp + Set RegEx = NewRegExp + + Set m_DeclDict = DeclDict + + Code = PrepareCode(Code, RegEx) + + Const ProcIndex As Long = 0 + Const EnumTypeIndex As Long = 1 + + Dim Patterns(2) As String + + Patterns(ProcIndex) = "(?:\r|\n|^)\s*(?:Sub|Function|Property Get|Property Let|Property Set|Event)\s+([^\r\n]*)" + Patterns(EnumTypeIndex) = "(?:\r|\n|^)\s*(?:Enum|Type)([\s\S]*?)(?:End\s+(?:Enum|Type))" + Patterns(2) = "(?:\r|\n|^)\s*(?:Dim|ReDim|Private|Friend|Public|Const|Static|Global|Implements)\s+([^\r\n]*)" + + Dim i As Long + For i = 0 To UBound(Patterns) + RegEx.Pattern = Patterns(i) + AddFromCode Code, RegEx, i = ProcIndex, i = EnumTypeIndex + Next + +End Sub + +Private Function NewRegExp() As RegExp + + Dim RegEx As RegExp + + Set RegEx = New RegExp + RegEx.IgnoreCase = True + RegEx.Global = True + + Set NewRegExp = RegEx + +End Function + +Private Function PrepareCode(ByVal Code As String, ByVal RegEx As RegExp) As String + + Code = Replace(Code, " _" & vbNewLine, " ") + +#If DebugPrintEnabled Then + DebugPrint Code, True, "PrepareCode - after Replace ' _' & vbNewLine" +#End If + + With RegEx + + ' clear all strings + .Pattern = """[^""\r\n]*""" + Code = .Replace(Code, "") + + ' remove comments + '.Pattern = "'(.*)[\r\n]" + .Pattern = "'(.*)([\r\n]|$)" + Code = .Replace(Code, "$2") + +#If DebugPrintEnabled Then + DebugPrint Code, True, "PrepareCode- after remove comments" +#End If + + ' treat line labels as dim (but not line numbers) + .Pattern = "([\r\n]|^)([^0-9\r\n]\S*):(\s|[\r\n]|$)" + Code = .Replace(Code, "$1Dim $2:$3") + + ' dim a as String: a = 5 => insert line break + .Pattern = "(\:\s)" + Code = .Replace(Code, vbNewLine) + + ' remove Withevents + .Pattern = "(Public|Private|Friend|Global)\sWithEvents\s" + Code = .Replace(Code, "$1 ") + + ' API declaration => convert to normal procedure declaration + .Pattern = "(?:Declare PtrSafe)\s(Function|Sub)\s" + Code = .Replace(Code, "Declare $1 ") + + RegEx.Pattern = "(?:Declare)\s(Function|Sub)\s([^ ]*)[^(]*\(" + Code = .Replace(Code, "$1 $2(") + + ' remove Static before Function, Sub, Property, .. + .Pattern = "(?:Static)+\s(Function|Sub|Property)\s" + Code = .Replace(Code, "$1 ") + + ' remove Public, Private, Friend before Function, Sub, Property, .. + .Pattern = "(?:Public|Private|Friend|Global)\s(Function|Sub|Property|Event|Enum|Type|Const)\s" + Code = .Replace(Code, "$1 ") + + End With + +#If DebugPrintEnabled Then + DebugPrint Code, True, "PrepareCode - completed" +#End If + + PrepareCode = Code + +End Function + +Private Sub AddFromCode(ByVal Code As String, ByVal RegEx As RegExp, ByVal IsProcedure As Boolean, ByVal IsEnumTypeBlock As Boolean) + + Dim Match As Match + Dim i As Long + + For Each Match In RegEx.Execute(Code) + For i = 0 To Match.SubMatches.Count - 1 + AddWordFromDeclaration Match.SubMatches(i), IsProcedure, IsEnumTypeBlock + Next + Next + +End Sub + +Private Sub AddWordFromDeclaration(ByRef Declarations As String, ByVal IsProcedure As Boolean, ByVal IsEnumTypeBlock As Boolean) + + Dim Word As String + Dim i As Long + Dim Pos As Long + Dim PosX As Long + + Dim DeclArray() As String + + If IsEnumTypeBlock Then + Declarations = Replace(Declarations, vbCr, ",") + Declarations = Replace(Declarations, vbLf, vbNullString) + End If + + Declarations = Trim(Declarations) + + If IsProcedure Then + ' Debug.Print Declarations + Declarations = Replace(Declarations, "()", vbNullString) + Declarations = Replace(Declarations, "Optional ", vbNullString) + Declarations = Replace(Declarations, "ByRef ", vbNullString) + Declarations = Replace(Declarations, "ByVal ", vbNullString) + Declarations = Replace(Declarations, "ParamArray ", vbNullString) + + Pos = InStr(1, Declarations, "(") + If Pos > 0 Then + Mid(Declarations, Pos, 1) = "," + End If + Declarations = Replace(Declarations, ")", vbNullString) + End If + + Do While InStr(1, Declarations, " ") > 0 + Declarations = Replace(Declarations, " ", " ") + Loop + + If Not (IsProcedure Or IsEnumTypeBlock) Then + Do While Declarations Like "*(*,*)*" + ' prevent multi-dimensional Dim from transforming into new declarations (might be numeric) + Pos = InStr(1, Declarations, "(") + PosX = InStr(Pos, Declarations, ")") + Declarations = Left(Declarations, Pos - 1) & " " & Mid(Declarations, PosX + 1) + Loop + End If + + DeclArray = Split(Trim(Declarations), ",") + + For i = LBound(DeclArray) To UBound(DeclArray) + Word = Trim(DeclArray(i)) + Pos = CutPos(Word) + If Pos > 1 Then + Word = Trim(Left(Word, Pos - 1)) + End If + If Len(Word) > 0 Then + m_DeclDict.AddWord Word + End If + Next + +End Sub + +Private Function CutPos(ByVal Expression As String) As Long + + Dim Pos As Long + Dim PosX As Long + + Const CutChars As String = " ()" + + Dim i As Long + + For i = 1 To Len(CutChars) + PosX = InStr(1, Expression, Mid(CutChars, i, 1)) + If PosX > 0 Then + If Pos = 0 Or PosX < Pos Then + Pos = PosX + End If + End If + Next + + CutPos = Pos + +End Function diff --git a/source/modules/DeclarationDict.cls b/source/modules/DeclarationDict.cls index b743ce9..d0ed720 100644 --- a/source/modules/DeclarationDict.cls +++ b/source/modules/DeclarationDict.cls @@ -7,7 +7,7 @@ Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False -Option Compare Database +Option Compare Text Option Explicit #Const DebugPrintEnabled = 0 @@ -121,7 +121,9 @@ Public Sub AddWord(ByVal Word As String) If Not m_Words.Exists(Word) Then m_Words.Add Word, Word m_WordVariations.Add Word, GetNewDict(BinaryCompare) - RaiseInsert = True + m_WordVariations.Item(Word).Add Word, Word + RaiseEvent WordInserted(Word) + Exit Sub End If Set SubDict = m_WordVariations.Item(Word) @@ -139,224 +141,12 @@ Public Sub AddWord(ByVal Word As String) End If End With - If RaiseInsert Then - RaiseEvent WordInserted(Word) - ElseIf RaiseChanged Then + If RaiseChanged Then RaiseEvent WordChanged(Word) End If End Sub -Public Sub ImportVBProject(ByVal VBProject2Import As VBProject) - - Dim vbc As VBComponent - - For Each vbc In VBProject2Import.VBComponents - ImportVBComponent vbc - Next - -End Sub - -Public Sub ImportVBComponent(ByVal VBComponent2Import As VBComponent) - ImportCodeModule VBComponent2Import.CodeModule -End Sub - -Public Sub ImportCodeModule(ByVal CodeModule2Import As CodeModule) - If CodeModule2Import.CountOfLines > 0 Then - ImportCode CodeModule2Import.Lines(1, CodeModule2Import.CountOfLines) - End If -End Sub - -Public Sub ImportCode(ByVal Code As String) - - Dim RegEx As RegExp - Set RegEx = NewRegExp - - Code = PrepareCode(Code, RegEx) - - Const ProcIndex As Long = 0 - Const EnumTypeIndex As Long = 1 - - Dim Patterns(2) As String - - Patterns(ProcIndex) = "(?:\r|\n|^)\s*(?:Sub|Function|Property Get|Property Let|Property Set|Event)\s+([^\r\n]*)" - Patterns(EnumTypeIndex) = "(?:\r|\n|^)\s*(?:Enum|Type)([\s\S]*?)(?:End\s+(?:Enum|Type))" - Patterns(2) = "(?:\r|\n|^)\s*(?:Dim|ReDim|Private|Friend|Public|Const|Static|Global|Implements)\s+([^\r\n]*)" - - Dim i As Long - For i = 0 To UBound(Patterns) - RegEx.Pattern = Patterns(i) - AddFromCode Code, RegEx, i = ProcIndex, i = EnumTypeIndex - Next - -End Sub - -Private Function NewRegExp() As RegExp - - Dim RegEx As RegExp - - Set RegEx = New RegExp - RegEx.IgnoreCase = True - RegEx.Global = True - - Set NewRegExp = RegEx - -End Function - -Private Function PrepareCode(ByVal Code As String, ByVal RegEx As RegExp) As String - - Code = Replace(Code, " _" & vbNewLine, " ") - -#If DebugPrintEnabled Then - DebugPrint Code, True, "PrepareCode - after Replace ' _' & vbNewLine" -#End If - - With RegEx - - ' clear all strings - .Pattern = """[^""\r\n]*""" - Code = .Replace(Code, "") - - ' remove comments - '.Pattern = "'(.*)[\r\n]" - .Pattern = "'(.*)([\r\n]|$)" - Code = .Replace(Code, "$2") - -#If DebugPrintEnabled Then - DebugPrint Code, True, "PrepareCode- after remove comments" -#End If - - ' treat line labels as dim (but not line numbers) - .Pattern = "([\r\n]|^)([^0-9\r\n]\S*):(\s|[\r\n]|$)" - Code = .Replace(Code, "$1Dim $2:$3") - - ' dim a as String: a = 5 => insert line break - .Pattern = "(\:\s)" - Code = .Replace(Code, vbNewLine) - - ' remove Withevents - .Pattern = "(Public|Private|Friend|Global)\sWithEvents\s" - Code = .Replace(Code, "$1 ") - - ' API declaration => convert to normal procedure declaration - .Pattern = "(?:Declare PtrSafe)\s(Function|Sub)\s" - Code = .Replace(Code, "Declare $1 ") - - RegEx.Pattern = "(?:Declare)\s(Function|Sub)\s([^ ]*)[^(]*\(" - Code = .Replace(Code, "$1 $2(") - - ' remove Static before Function, Sub, Property, .. - .Pattern = "(?:Static)+\s(Function|Sub|Property)\s" - Code = .Replace(Code, "$1 ") - - ' remove Public, Private, Friend before Function, Sub, Property, .. - .Pattern = "(?:Public|Private|Friend|Global)\s(Function|Sub|Property|Event|Enum|Type|Const)\s" - Code = .Replace(Code, "$1 ") - - End With - -#If DebugPrintEnabled Then - DebugPrint Code, True, "PrepareCode - completed" -#End If - - PrepareCode = Code - -End Function - -Private Sub AddFromCode(ByVal Code As String, ByVal RegEx As RegExp, ByVal IsProcedure As Boolean, ByVal IsEnumTypeBlock As Boolean) - - Dim Match As Match - Dim i As Long - - For Each Match In RegEx.Execute(Code) - For i = 0 To Match.SubMatches.Count - 1 - AddWordFromDeclaration Match.SubMatches(i), IsProcedure, IsEnumTypeBlock - Next - Next - -End Sub - -Private Sub AddWordFromDeclaration(ByRef Declarations As String, ByVal IsProcedure As Boolean, ByVal IsEnumTypeBlock As Boolean) - - Dim Word As String - Dim i As Long - Dim Pos As Long - Dim PosX As Long - - Dim DeclArray() As String - - If IsEnumTypeBlock Then - Declarations = Replace(Declarations, vbCr, ",") - Declarations = Replace(Declarations, vbLf, vbNullString) - End If - - Declarations = Trim(Declarations) - - If IsProcedure Then - ' Debug.Print Declarations - Declarations = Replace(Declarations, "()", vbNullString) - Declarations = Replace(Declarations, "Optional ", vbNullString) - Declarations = Replace(Declarations, "ByRef ", vbNullString) - Declarations = Replace(Declarations, "ByVal ", vbNullString) - Declarations = Replace(Declarations, "ParamArray ", vbNullString) - - Pos = InStr(1, Declarations, "(") - If Pos > 0 Then - Mid(Declarations, Pos, 1) = "," - End If - Declarations = Replace(Declarations, ")", vbNullString) - End If - - Do While InStr(1, Declarations, " ") > 0 - Declarations = Replace(Declarations, " ", " ") - Loop - - If Not IsProcedure And Not IsEnumTypeBlock Then - Do While Declarations Like "*(*,*)*" - ' prevent multi-dimensional Dim from transforming into new declarations (might be numeric) - Pos = InStr(1, Declarations, "(") - PosX = InStr(Pos, Declarations, ")") - Declarations = Left(Declarations, Pos - 1) & " " & Mid(Declarations, PosX + 1) - Loop - End If - - DeclArray = Split(Trim(Declarations), ",") - - For i = LBound(DeclArray) To UBound(DeclArray) - Word = Trim(DeclArray(i)) - Pos = CutPos(Word) - If Pos > 1 Then - Word = Trim(Left(Word, Pos - 1)) - End If - If Len(Word) > 0 Then - AddWord Word - End If - Next - -End Sub - -Private Function CutPos(ByVal Expression As String) As Long - - Dim Pos As Long - Dim PosX As Long - - Const CutChars As String = " ()" - - Dim i As Long - - For i = 1 To Len(CutChars) - PosX = InStr(1, Expression, Mid(CutChars, i, 1)) - If PosX > 0 Then - If Pos = 0 Or PosX < Pos Then - Pos = PosX - End If - End If - Next - - CutPos = Pos - -End Function - Public Function ToString(Optional ByVal ShowAll As Boolean = False) As String Dim WordKey As Variant @@ -472,6 +262,9 @@ Public Sub FixLetterCase(ByVal WordWithNewLetterCase As String) With New CodeModulGenerator .CreateCodemodule vbext_ct_StdModule + If Left(WordWithNewLetterCase, 1) = "_" Then + WordWithNewLetterCase = "[" & WordWithNewLetterCase & "]" + End If .InsertDeclarationLine "Private " & WordWithNewLetterCase .RemoveCodemodule End With diff --git a/source/modules/FileTools.bas b/source/modules/FileTools.bas index 4bfebf0..92db18b 100644 --- a/source/modules/FileTools.bas +++ b/source/modules/FileTools.bas @@ -753,7 +753,7 @@ Public Sub AddToZipFile(ByVal ZipFile As String, ByVal FullFileName As String) End If With CreateObject("Shell.Application") - .NameSpace(ZipFile & "").CopyHere FullFileName & "" + .Namespace(ZipFile & "").CopyHere FullFileName & "" End With End Sub @@ -775,8 +775,8 @@ End Sub Public Function ExtractFromZipFile(ByVal ZipFile As String, ByVal Destination As String) As String With CreateObject("Shell.Application") - .NameSpace(Destination & "").CopyHere .NameSpace(ZipFile & "").Items - ExtractFromZipFile = .NameSpace(ZipFile & "").Items.Item(0).Name + .Namespace(Destination & "").CopyHere .Namespace(ZipFile & "").Items + ExtractFromZipFile = .Namespace(ZipFile & "").Items.Item(0).Name End With End Function diff --git a/source/modules/_AddInAPI.bas b/source/modules/_AddInAPI.bas index 9a57ac1..bdb1117 100644 --- a/source/modules/_AddInAPI.bas +++ b/source/modules/_AddInAPI.bas @@ -51,52 +51,59 @@ Public Function RunVcsCheck(Optional ByVal OpenDialogToFixLettercase As Boolean Dim StoreDictData As Boolean Dim IntialCnt As Long - With New DeclarationDict - - If Len(DeclDictFilePath) = 0 Then - DeclDictFilePath = CurrentProject.Path & "\" & CurrentProject.Name & ".DeclarationDict.txt" - End If - - If Not .LoadFromFile(DeclDictFilePath) Then - .ImportVBProject CurrentVbProject - ' ... log info: first export - .ExportToFile DeclDictFilePath - RunVcsCheck = "Info: No dictionary data found. A new dictionary has been created." - Exit Function + Dim DeclDict As DeclarationDict + Set DeclDict = New DeclarationDict + + If Len(DeclDictFilePath) = 0 Then + DeclDictFilePath = CurrentProject.Path & "\" & CurrentProject.Name & ".DeclarationDict.txt" + End If + + If Not DeclDict.LoadFromFile(DeclDictFilePath) Then + ImportVBProject CurrentVbProject, DeclDict + ' ... log info: first export + DeclDict.ExportToFile DeclDictFilePath + RunVcsCheck = "Info: No dictionary data found. A new dictionary has been created." + Exit Function + End If + + IntialCnt = DeclDict.Count + ImportVBProject CurrentVbProject, DeclDict + + DiffCnt = DeclDict.DiffCount + If DiffCnt = 0 Then + If DeclDict.Count <> IntialCnt Then + StoreDictData = True End If + End If - IntialCnt = .Count - .ImportVBProject CurrentVbProject - - DiffCnt = .DiffCount - If DiffCnt = 0 Then - If .Count <> IntialCnt Then + If OpenDialogToFixLettercase Then + If DiffCnt > 0 Then + SetDeclarationDictTransferReference DeclDict + DoCmd.OpenForm "DeclarationDictApiDialog", , , , , acDialog + DiffCnt = DeclDict.DiffCount + If DiffCnt = 0 Then StoreDictData = True End If End If + End If - If OpenDialogToFixLettercase Then - If DiffCnt > 0 Then - SetDeclarationDictTransferReference .Self - DoCmd.OpenForm "DeclarationDictApiDialog", , , , , acDialog - DiffCnt = .DiffCount - If DiffCnt = 0 Then - StoreDictData = True - End If - End If - End If + If StoreDictData Then + DeclDict.ExportToFile DeclDictFilePath + End If - If StoreDictData Then - .ExportToFile DeclDictFilePath - End If + If DiffCnt > 0 Then + CheckMsg = DeclDict.DiffCount & " word" & IIf(DeclDict.DiffCount > 1, "s", vbNullString) & " with different letter case" + RunVcsCheck = "Failed: " & CheckMsg + Else + RunVcsCheck = True + End If - If DiffCnt > 0 Then - CheckMsg = .DiffCount & " word" & IIf(.DiffCount > 1, "s", vbNullString) & " with different letter case" - RunVcsCheck = "Failed: " & CheckMsg - Else - RunVcsCheck = True - End If +End Function + +Private Sub ImportVBProject(ByVal VbProjectToImport As VBIDE.VBProject, ByVal DeclDict As DeclarationDict) + With New CodemoduleDeclarationReader + .ImportVBProject VbProjectToImport, DeclDict End With -End Function +End Sub diff --git a/source/vcs-options.json b/source/vcs-options.json index c55c9fc..f66575f 100644 --- a/source/vcs-options.json +++ b/source/vcs-options.json @@ -1,6 +1,6 @@ { "Info": { - "AddinVersion": "4.1.2", + "AddinVersion": "4.1.3", "AccessVersion": "16.0 64-bit" }, "Options": { From 2607f7fc43ea0779ffe371f7a8940d28842f6228 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Sun, 29 Jun 2025 17:19:04 +0200 Subject: [PATCH 02/13] Implemented: add members to dict (thanks to @hrschupp - see commit https://github.com/hrschupp/ACLibDeclarationDictionaryCore/commit/861031d695c236f3b7872f191e2d3a1570d35fca) --- .../modules/CodemoduleDeclarationReader.cls | 32 +++++++++++-------- source/modules/_AddInAPI.bas | 16 ++++++---- 2 files changed, 28 insertions(+), 20 deletions(-) diff --git a/source/modules/CodemoduleDeclarationReader.cls b/source/modules/CodemoduleDeclarationReader.cls index e2245d2..47cfcd9 100644 --- a/source/modules/CodemoduleDeclarationReader.cls +++ b/source/modules/CodemoduleDeclarationReader.cls @@ -12,27 +12,27 @@ Option Explicit Private m_DeclDict As DeclarationDict -Public Sub ImportVBProject(ByVal VBProject2Import As VBProject, ByVal DeclDict As DeclarationDict) +Public Sub ImportVBProject(ByVal VBProject2Import As VBProject, ByVal DeclDict As DeclarationDict, Optional ByVal IncludeUsedMembers As Boolean = False) Dim vbc As VBComponent For Each vbc In VBProject2Import.VBComponents - ImportVBComponent vbc, DeclDict + ImportVBComponent vbc, DeclDict, IncludeUsedMembers Next End Sub -Public Sub ImportVBComponent(ByVal VBComponent2Import As VBComponent, ByVal DeclDict As DeclarationDict) - ImportCodeModule VBComponent2Import.CodeModule, DeclDict +Public Sub ImportVBComponent(ByVal VBComponent2Import As VBComponent, ByVal DeclDict As DeclarationDict, Optional ByVal IncludeUsedMembers As Boolean = False) + ImportCodeModule VBComponent2Import.CodeModule, DeclDict, IncludeUsedMembers End Sub -Public Sub ImportCodeModule(ByVal CodeModule2Import As CodeModule, ByVal DeclDict As DeclarationDict) +Public Sub ImportCodeModule(ByVal CodeModule2Import As CodeModule, ByVal DeclDict As DeclarationDict, Optional ByVal IncludeUsedMembers As Boolean = False) If CodeModule2Import.CountOfLines > 0 Then - ImportCode CodeModule2Import.Lines(1, CodeModule2Import.CountOfLines), DeclDict + ImportCode CodeModule2Import.Lines(1, CodeModule2Import.CountOfLines), DeclDict, IncludeUsedMembers End If End Sub -Public Sub ImportCode(ByVal Code As String, ByVal DeclDict As DeclarationDict) +Public Sub ImportCode(ByVal Code As String, ByVal DeclDict As DeclarationDict, Optional ByVal IncludeUsedMembers As Boolean = False) Dim RegEx As RegExp Set RegEx = NewRegExp @@ -43,17 +43,23 @@ Public Sub ImportCode(ByVal Code As String, ByVal DeclDict As DeclarationDict) Const ProcIndex As Long = 0 Const EnumTypeIndex As Long = 1 + Const DimIndex As Long = 2 - Dim Patterns(2) As String + Dim Patterns() As String + ReDim Patterns(2 + Abs(IncludeUsedMembers)) As String Patterns(ProcIndex) = "(?:\r|\n|^)\s*(?:Sub|Function|Property Get|Property Let|Property Set|Event)\s+([^\r\n]*)" Patterns(EnumTypeIndex) = "(?:\r|\n|^)\s*(?:Enum|Type)([\s\S]*?)(?:End\s+(?:Enum|Type))" Patterns(2) = "(?:\r|\n|^)\s*(?:Dim|ReDim|Private|Friend|Public|Const|Static|Global|Implements)\s+([^\r\n]*)" + If IncludeUsedMembers Then + 'see: https://github.com/hrschupp/ACLibDeclarationDictionaryCore/commit/861031d695c236f3b7872f191e2d3a1570d35fca#diff-0a954b2b22b447d5669ac2cc27824aef945ba74307ebf8c3c3c2c5dc67080afa + Patterns(3) = "(?:[.!])([^0-9\s.!_\(\)\[\]\r\n][^\s.!\(\)\[\]\r\n]*)(?:\s|[.!\(\)\[\]\r\n]|$)" + End If Dim i As Long For i = 0 To UBound(Patterns) RegEx.Pattern = Patterns(i) - AddFromCode Code, RegEx, i = ProcIndex, i = EnumTypeIndex + AddFromCode Code, RegEx, i = ProcIndex, i = EnumTypeIndex, i = DimIndex Next End Sub @@ -130,20 +136,20 @@ Private Function PrepareCode(ByVal Code As String, ByVal RegEx As RegExp) As Str End Function -Private Sub AddFromCode(ByVal Code As String, ByVal RegEx As RegExp, ByVal IsProcedure As Boolean, ByVal IsEnumTypeBlock As Boolean) +Private Sub AddFromCode(ByVal Code As String, ByVal RegEx As RegExp, ByVal IsProcedure As Boolean, ByVal IsEnumTypeBlock As Boolean, ByVal IsDimBlock As Boolean) Dim Match As Match Dim i As Long For Each Match In RegEx.Execute(Code) For i = 0 To Match.SubMatches.Count - 1 - AddWordFromDeclaration Match.SubMatches(i), IsProcedure, IsEnumTypeBlock + AddWordFromDeclaration Match.SubMatches(i), IsProcedure, IsEnumTypeBlock, IsDimBlock Next Next End Sub -Private Sub AddWordFromDeclaration(ByRef Declarations As String, ByVal IsProcedure As Boolean, ByVal IsEnumTypeBlock As Boolean) +Private Sub AddWordFromDeclaration(ByRef Declarations As String, ByVal IsProcedure As Boolean, ByVal IsEnumTypeBlock As Boolean, ByVal IsDimBlock As Boolean) Dim Word As String Dim i As Long @@ -178,7 +184,7 @@ Private Sub AddWordFromDeclaration(ByRef Declarations As String, ByVal IsProcedu Declarations = Replace(Declarations, " ", " ") Loop - If Not (IsProcedure Or IsEnumTypeBlock) Then + If IsDimBlock Then Do While Declarations Like "*(*,*)*" ' prevent multi-dimensional Dim from transforming into new declarations (might be numeric) Pos = InStr(1, Declarations, "(") diff --git a/source/modules/_AddInAPI.bas b/source/modules/_AddInAPI.bas index bdb1117..e03605b 100644 --- a/source/modules/_AddInAPI.bas +++ b/source/modules/_AddInAPI.bas @@ -19,11 +19,11 @@ End Function ' Function: RunVcsCheckDialog '--------------------------------------------------------------------------------------- ' -' Equal to RunVcsCheck(True) +' Equal to RunVcsCheck(True, vbNullString, True) ' '--------------------------------------------------------------------------------------- Public Function RunVcsCheckDialog() As Variant - RunVcsCheckDialog = RunVcsCheck(True) + RunVcsCheckDialog = RunVcsCheck(True, , True) End Function @@ -43,7 +43,8 @@ End Function ' '--------------------------------------------------------------------------------------- Public Function RunVcsCheck(Optional ByVal OpenDialogToFixLettercase As Boolean = False, _ - Optional ByVal DeclDictFilePath As String = vbNullString) As Variant + Optional ByVal DeclDictFilePath As String = vbNullString, _ + Optional ByVal IncludeUsedMembers As Boolean = False) As Variant Dim CheckMsg As String Dim DiffCnt As Long @@ -59,7 +60,7 @@ Public Function RunVcsCheck(Optional ByVal OpenDialogToFixLettercase As Boolean End If If Not DeclDict.LoadFromFile(DeclDictFilePath) Then - ImportVBProject CurrentVbProject, DeclDict + ImportVBProject CurrentVbProject, DeclDict, IncludeUsedMembers ' ... log info: first export DeclDict.ExportToFile DeclDictFilePath RunVcsCheck = "Info: No dictionary data found. A new dictionary has been created." @@ -67,7 +68,7 @@ Public Function RunVcsCheck(Optional ByVal OpenDialogToFixLettercase As Boolean End If IntialCnt = DeclDict.Count - ImportVBProject CurrentVbProject, DeclDict + ImportVBProject CurrentVbProject, DeclDict, IncludeUsedMembers DiffCnt = DeclDict.DiffCount If DiffCnt = 0 Then @@ -100,10 +101,11 @@ Public Function RunVcsCheck(Optional ByVal OpenDialogToFixLettercase As Boolean End Function -Private Sub ImportVBProject(ByVal VbProjectToImport As VBIDE.VBProject, ByVal DeclDict As DeclarationDict) +Private Sub ImportVBProject(ByVal VbProjectToImport As VBIDE.VBProject, ByVal DeclDict As DeclarationDict, _ + Optional ByVal IncludeUsedMembers As Boolean = False) With New CodemoduleDeclarationReader - .ImportVBProject VbProjectToImport, DeclDict + .ImportVBProject VbProjectToImport, DeclDict, IncludeUsedMembers End With End Sub From 49c6b68dd60b3054ab9341c8bc8e981c104f8322 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Sun, 29 Jun 2025 17:25:50 +0200 Subject: [PATCH 03/13] upd. example file --- .gitignore | 5 ++++- Example_APIusage.accdb.src/modules/_LoadAddIn.bas | 6 ++++-- Example_APIusage.accdb.src/vcs-options.json | 2 +- 3 files changed, 9 insertions(+), 4 deletions(-) diff --git a/.gitignore b/.gitignore index 38de702..10ca69c 100644 --- a/.gitignore +++ b/.gitignore @@ -24,4 +24,7 @@ vcs-index.json # others *.dll -*.zip \ No newline at end of file +*.zip + +# don't commit dict files in this repository +*.accd[ab].DeclarationDict.txt \ No newline at end of file diff --git a/Example_APIusage.accdb.src/modules/_LoadAddIn.bas b/Example_APIusage.accdb.src/modules/_LoadAddIn.bas index 07ac9e2..4e02ab1 100644 --- a/Example_APIusage.accdb.src/modules/_LoadAddIn.bas +++ b/Example_APIusage.accdb.src/modules/_LoadAddIn.bas @@ -4,13 +4,15 @@ Option Explicit Public Sub LoadAddIn() -'API: RunVcsCheck(Optional ByVal OpenDialogToFixLettercase As Boolean = False) +'API: Public Function RunVcsCheck(Optional ByVal OpenDialogToFixLettercase As Boolean = False, _ +' Optional ByVal DeclDictFilePath As String = vbNullString, _ +' Optional ByVal IncludeUsedMembers As Boolean = False) As Variant Dim AddInCallPath As String AddInCallPath = CurrentProject.Path & "\ACLibDeclarationDictCore.RunVcsCheck" Dim Result As Variant - Result = Application.Run(AddInCallPath, True) + Result = Application.Run(AddInCallPath, True, vbNullString, True) If Result = True Then Debug.Print "No problems with letter case" Else diff --git a/Example_APIusage.accdb.src/vcs-options.json b/Example_APIusage.accdb.src/vcs-options.json index ead0f48..0d34347 100644 --- a/Example_APIusage.accdb.src/vcs-options.json +++ b/Example_APIusage.accdb.src/vcs-options.json @@ -1,6 +1,6 @@ { "Info": { - "AddinVersion": "4.1.2", + "AddinVersion": "4.1.3", "AccessVersion": "16.0 64-bit" }, "Options": { From 83cab96a6d96cbaa195424f4a4688470b0e67574 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= <115746022+josef-poetzl@users.noreply.github.com> Date: Sun, 27 Apr 2025 00:06:56 +0200 Subject: [PATCH 04/13] Update README.md --- README.md | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index 138225f..e5478a6 100644 --- a/README.md +++ b/README.md @@ -1,11 +1,15 @@ -# ACLib Declaration Dictionary (Core Components) +# ACLib Declaration Dictionary + This Add-In lists all VBA declarations (variables, function names, constants, etc.) and ensures consistent letter case. The idea was born from a discussion ([msaccess-vcs-add-in: issue 599](https://github.com/joyfullservice/msaccess-vcs-addin/issues/599)) about the behavior of the VBA editor, which adapts each existing declaration to the last written capitalization of the same word. This leads to many unnecessary changes in commits when using a version control system. -#### Core Components -This add-in is only designed to be called via Application.Run. -The complete Access menu add-in is [ACLibDeclarationDictionaryAddIn](https://github.com/AccessCodeLib/ACLibDeclarationDictionaryAddIn). + +![ACLibDeclarationDictionary](https://github.com/user-attachments/assets/0ef05ef7-72aa-4786-a790-74e679df7f24) + + +# ACLibDeclarationDictionaryCore +This Add-In lists all VBA declarations (variables, function names, constants, etc.) and ensures consistent letter case - Core components ## API From 46df98c612641c13f7e4637573d47bef880de4ca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= <115746022+josef-poetzl@users.noreply.github.com> Date: Sun, 27 Apr 2025 00:48:23 +0200 Subject: [PATCH 05/13] add add-in components, change license for add-in from MIT to GPL --- LICENSE | 695 ++++++++++- source/dbs-properties.json | 6 +- source/forms/DeclarationDictApiDialog.cls | 8 +- source/forms/DeclarationDictForm.bas | 922 +++++++++++++++ source/forms/DeclarationDictForm.cls | 396 +++++++ source/forms/InstallAddInForm.bas | 811 +++++++++++++ source/forms/InstallAddInForm.cls | 74 ++ source/modules/AddInConfiguration.cls | 340 ++++++ source/modules/AddInInstaller.cls | 192 ++++ source/modules/ApplicationHandler.cls | 728 ++++++++++++ source/modules/DaoTools.bas | 99 ++ source/modules/FilterStringBuilder.cls | 461 ++++++++ source/modules/Module1.bas | 18 + source/modules/SqlTools.cls | 1267 +++++++++++++++++++++ source/modules/StringCollection.cls | 318 ++++++ source/modules/_AddInAPI.bas | 11 + source/modules/_config_Application.bas | 96 ++ source/modules/_initApplication.bas | 63 + source/modules/modApplication.bas | 145 +++ source/modules/modErrorHandler.bas | 316 +++++ source/tables/USysRegInfo.txt | 4 + source/tbldefs/USysRegInfo.sql | 6 + source/tbldefs/USysRegInfo.xml | 65 ++ source/tbldefs/tabWords.sql | 5 + source/tbldefs/tabWords.xml | 104 ++ source/vbe-project.json | 4 +- 26 files changed, 7127 insertions(+), 27 deletions(-) create mode 100644 source/forms/DeclarationDictForm.bas create mode 100644 source/forms/DeclarationDictForm.cls create mode 100644 source/forms/InstallAddInForm.bas create mode 100644 source/forms/InstallAddInForm.cls create mode 100644 source/modules/AddInConfiguration.cls create mode 100644 source/modules/AddInInstaller.cls create mode 100644 source/modules/ApplicationHandler.cls create mode 100644 source/modules/DaoTools.bas create mode 100644 source/modules/FilterStringBuilder.cls create mode 100644 source/modules/Module1.bas create mode 100644 source/modules/SqlTools.cls create mode 100644 source/modules/StringCollection.cls create mode 100644 source/modules/_config_Application.bas create mode 100644 source/modules/_initApplication.bas create mode 100644 source/modules/modApplication.bas create mode 100644 source/modules/modErrorHandler.bas create mode 100644 source/tables/USysRegInfo.txt create mode 100644 source/tbldefs/USysRegInfo.sql create mode 100644 source/tbldefs/USysRegInfo.xml create mode 100644 source/tbldefs/tabWords.sql create mode 100644 source/tbldefs/tabWords.xml diff --git a/LICENSE b/LICENSE index c18713d..f288702 100644 --- a/LICENSE +++ b/LICENSE @@ -1,21 +1,674 @@ -MIT License - -Copyright (c) 2025 access-codelib.net - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/source/dbs-properties.json b/source/dbs-properties.json index 4528173..dbe610e 100644 --- a/source/dbs-properties.json +++ b/source/dbs-properties.json @@ -81,7 +81,7 @@ "Type": 3 }, "Name": { - "Value": "rel:ACLibDeclarationDictCore.accda", + "Value": "rel:ACLibDeclarationDict.accda", "Type": 12 }, "NavPane Category": { @@ -156,6 +156,10 @@ "Value": true, "Type": 1 }, + "StartUpForm": { + "Value": "InstallAddInForm", + "Type": 10 + }, "StartUpShowDBWindow": { "Value": true, "Type": 1 diff --git a/source/forms/DeclarationDictApiDialog.cls b/source/forms/DeclarationDictApiDialog.cls index d14bec7..3b85687 100644 --- a/source/forms/DeclarationDictApiDialog.cls +++ b/source/forms/DeclarationDictApiDialog.cls @@ -22,10 +22,12 @@ End Property Private Sub Form_Load() - Me.Caption = DeclDictAddInName & " " & ChrW(&H2022) & " Differences" - Me.lblVersionInfo.Caption = DeclDictAddInName & " " & ChrW(&H2022) & " Version " & DeclDictVersion + With CurrentApplication + Me.Caption = .ApplicationName & " " & ChrW(&H2022) & " Differences" + Me.lblVersionInfo.Caption = .ApplicationFullName & " " & ChrW(&H2022) & " Version " & CurrentApplication.Version + End With - SetApiDialogMode + SetApiDialogMode End Sub diff --git a/source/forms/DeclarationDictForm.bas b/source/forms/DeclarationDictForm.bas new file mode 100644 index 0000000..a5e7dfc --- /dev/null +++ b/source/forms/DeclarationDictForm.bas @@ -0,0 +1,922 @@ +Version =20 +VersionRequired =20 +Begin Form + PopUp = NotDefault + RecordSelectors = NotDefault + AutoCenter = NotDefault + NavigationButtons = NotDefault + DividingLines = NotDefault + AllowDesignChanges = NotDefault + DefaultView =0 + ScrollBars =0 + PictureAlignment =2 + DatasheetGridlinesBehavior =3 + Cycle =1 + GridY =10 + Width =10148 + DatasheetFontHeight =11 + ItemSuffix =81 + Left =7620 + Top =3045 + Right =20775 + Bottom =14775 + OnUnload ="[Event Procedure]" + RecSrcDt = Begin + 0x1b36415d9252e640 + End + Caption ="Declarations" + DatasheetFontName ="Calibri" + OnTimer ="[Event Procedure]" + OnLoad ="[Event Procedure]" + FilterOnLoad =0 + ShowPageMargins =0 + DisplayOnSharePointSite =1 + DatasheetAlternateBackColor =15921906 + DatasheetGridlinesColor12 =0 + FitToScreen =1 + DatasheetBackThemeColorIndex =1 + BorderThemeColorIndex =3 + ThemeFontIndex =1 + ForeThemeColorIndex =0 + AlternateBackThemeColorIndex =1 + AlternateBackShade =95.0 + Begin + Begin Label + BackStyle =0 + FontSize =11 + FontName ="Calibri" + ThemeFontIndex =1 + BackThemeColorIndex =1 + BorderThemeColorIndex =0 + BorderTint =50.0 + ForeThemeColorIndex =0 + ForeTint =60.0 + GridlineThemeColorIndex =1 + GridlineShade =65.0 + End + Begin CommandButton + Width =1701 + Height =283 + FontSize =11 + FontWeight =400 + ForeColor =4210752 + FontName ="Calibri" + GridlineColor =10921638 + ForeTint =75.0 + GridlineShade =65.0 + UseTheme =1 + Shape =1 + Gradient =12 + BackColor =14136213 + BackTint =60.0 + BorderLineStyle =0 + BorderColor =14136213 + BorderTint =60.0 + ThemeFontIndex =1 + HoverColor =15060409 + HoverTint =40.0 + PressedColor =9592887 + PressedShade =75.0 + HoverForeColor =4210752 + HoverForeTint =75.0 + PressedForeColor =4210752 + PressedForeTint =75.0 + End + Begin OptionButton + BorderLineStyle =0 + LabelX =230 + LabelY =-30 + BorderThemeColorIndex =1 + BorderShade =65.0 + GridlineThemeColorIndex =1 + GridlineShade =65.0 + End + Begin OptionGroup + SpecialEffect =3 + BorderLineStyle =0 + Width =1701 + Height =1701 + BackThemeColorIndex =1 + BorderThemeColorIndex =1 + BorderShade =65.0 + GridlineThemeColorIndex =1 + GridlineShade =65.0 + End + Begin TextBox + AddColon = NotDefault + FELineBreak = NotDefault + BorderLineStyle =0 + Width =1701 + LabelX =-1701 + FontSize =11 + FontName ="Calibri" + AsianLineBreak =1 + BackThemeColorIndex =1 + BorderThemeColorIndex =1 + BorderShade =65.0 + ThemeFontIndex =1 + ForeThemeColorIndex =0 + ForeTint =75.0 + GridlineThemeColorIndex =1 + GridlineShade =65.0 + End + Begin ListBox + BorderLineStyle =0 + Width =1701 + Height =1417 + LabelX =-1701 + FontSize =11 + FontName ="Calibri" + AllowValueListEdits =1 + InheritValueList =1 + ThemeFontIndex =1 + BackThemeColorIndex =1 + BorderThemeColorIndex =1 + BorderShade =65.0 + ForeThemeColorIndex =0 + ForeTint =75.0 + GridlineThemeColorIndex =1 + GridlineShade =65.0 + End + Begin EmptyCell + Height =240 + GridlineThemeColorIndex =1 + GridlineShade =65.0 + End + Begin Section + Height =6236 + Name ="Detail" + AlternateBackThemeColorIndex =1 + AlternateBackShade =95.0 + BackThemeColorIndex =1 + Begin + Begin ListBox + OverlapFlags =85 + IMESentenceMode =3 + ColumnCount =2 + Left =60 + Top =789 + Width =5416 + Height =4542 + FontSize =9 + TabIndex =11 + Name ="lbDictData" + RowSourceType ="Table/Query" + ColumnWidths ="2835" + AfterUpdate ="[Event Procedure]" + HorizontalAnchor =2 + VerticalAnchor =2 + AllowValueListEdits =0 + InheritValueList =0 + + LayoutCachedLeft =60 + LayoutCachedTop =789 + LayoutCachedWidth =5476 + LayoutCachedHeight =5331 + End + Begin OptionGroup + SpecialEffect =0 + OldBorderStyle =0 + OverlapFlags =93 + Left =57 + Width =5103 + Height =456 + TabIndex =1 + Name ="filtDiff" + AfterUpdate ="[Event Procedure]" + DefaultValue ="1" + HorizontalAnchor =2 + + LayoutCachedLeft =57 + LayoutCachedWidth =5160 + LayoutCachedHeight =456 + Begin + Begin Label + BackStyle =1 + OverlapFlags =215 + Left =120 + Top =60 + Width =840 + Height =345 + Name ="labFilterSelection" + Caption ="Show" + LayoutCachedLeft =120 + LayoutCachedTop =60 + LayoutCachedWidth =960 + LayoutCachedHeight =405 + End + Begin OptionButton + OverlapFlags =87 + Left =1020 + Top =80 + OptionValue =1 + Name ="Option4" + + LayoutCachedLeft =1020 + LayoutCachedTop =80 + LayoutCachedWidth =1280 + LayoutCachedHeight =320 + Begin + Begin Label + OverlapFlags =247 + Left =1250 + Top =50 + Width =1200 + Height =315 + Name ="Label5" + Caption ="Differences " + LayoutCachedLeft =1250 + LayoutCachedTop =50 + LayoutCachedWidth =2450 + LayoutCachedHeight =365 + End + End + End + Begin OptionButton + OverlapFlags =87 + Left =2608 + Top =80 + TabIndex =1 + OptionValue =0 + Name ="Option6" + + LayoutCachedLeft =2608 + LayoutCachedTop =80 + LayoutCachedWidth =2868 + LayoutCachedHeight =320 + Begin + Begin Label + OverlapFlags =247 + Left =2838 + Top =50 + Width =825 + Height =315 + Name ="Label7" + Caption ="Full list" + LayoutCachedLeft =2838 + LayoutCachedTop =50 + LayoutCachedWidth =3663 + LayoutCachedHeight =365 + End + End + End + End + End + Begin ListBox + RowSourceTypeInt =1 + OverlapFlags =85 + IMESentenceMode =3 + Left =5674 + Top =1911 + Width =4380 + Height =1354 + TabIndex =8 + ForeColor =0 + Name ="lbVariations" + RowSourceType ="Value List" + AfterUpdate ="[Event Procedure]" + GroupTable =1 + TopPadding =0 + GridlineWidthLeft =0 + GridlineWidthTop =0 + GridlineWidthRight =0 + GridlineWidthBottom =0 + HorizontalAnchor =1 + AllowValueListEdits =0 + InheritValueList =0 + + LayoutCachedLeft =5674 + LayoutCachedTop =1911 + LayoutCachedWidth =10054 + LayoutCachedHeight =3265 + RowStart =4 + RowEnd =4 + ColumnEnd =1 + LayoutGroup =1 + ForeTint =100.0 + GroupTable =1 + End + Begin TextBox + Locked = NotDefault + OldBorderStyle =0 + OverlapFlags =85 + TextAlign =1 + IMESentenceMode =3 + Left =5674 + Top =574 + Width =4380 + Height =317 + FontWeight =700 + TabIndex =6 + Name ="txtWord" + ControlSource ="=[lbDictData]" + Format ="@;;\"(select item)\"" + ConditionalFormat = Begin + 0x0100000086000000010000000100000000000000000000001200000001000000 , + 0xbfbfbf00ffffff00000000000000000000000000000000000000000000000000 , + 0x0000000000000000000000000000000000000000000000000000000000000000 , + 0x5b0074007800740057006f00720064005d0020004900730020004e0075006c00 , + 0x6c0000000000 + End + GroupTable =1 + HorizontalAnchor =1 + + LayoutCachedLeft =5674 + LayoutCachedTop =574 + LayoutCachedWidth =10054 + LayoutCachedHeight =891 + ColumnEnd =1 + LayoutGroup =1 + ConditionalFormat14 = Begin + 0x010001000000010000000000000001000000bfbfbf00ffffff00110000005b00 , + 0x74007800740057006f00720064005d0020004900730020004e0075006c006c00 , + 0x000000000000000000000000000000000000000000 + End + GroupTable =1 + End + Begin CommandButton + OverlapFlags =85 + Left =5494 + Top =60 + Height =397 + TabIndex =3 + Name ="cmdUpdateDict" + Caption ="update data" + OnClick ="[Event Procedure]" + + LayoutCachedLeft =5494 + LayoutCachedTop =60 + LayoutCachedWidth =7195 + LayoutCachedHeight =457 + ForeThemeColorIndex =0 + GridlineThemeColorIndex =1 + BackThemeColorIndex =4 + BorderThemeColorIndex =4 + HoverThemeColorIndex =4 + PressedThemeColorIndex =4 + HoverForeThemeColorIndex =0 + PressedForeThemeColorIndex =0 + Overlaps =1 + End + Begin TextBox + Enabled = NotDefault + Locked = NotDefault + TabStop = NotDefault + OldBorderStyle =0 + OverlapFlags =215 + TextAlign =3 + BackStyle =0 + IMESentenceMode =3 + Left =3741 + Top =56 + Width =1248 + Height =300 + TabIndex =2 + Name ="txtDictInfo" + HorizontalAnchor =2 + + LayoutCachedLeft =3741 + LayoutCachedTop =56 + LayoutCachedWidth =4989 + LayoutCachedHeight =356 + End + Begin CommandButton + Transparent = NotDefault + OverlapFlags =85 + Width =0 + Height =0 + Name ="Command15" + Caption ="sysFirst" + + ForeThemeColorIndex =0 + GridlineThemeColorIndex =1 + BackThemeColorIndex =4 + BorderThemeColorIndex =4 + HoverThemeColorIndex =4 + PressedThemeColorIndex =4 + HoverForeThemeColorIndex =0 + PressedForeThemeColorIndex =0 + Overlaps =1 + End + Begin Label + OverlapFlags =85 + Left =5669 + Top =4081 + Width =2595 + Height =1402 + Name ="Label17" + Caption ="Test steps:\015\012 1. [update data]\015\012 2. change lettercase\015\012 " + "3. [update data]\015\012 4. show differences " + HorizontalAnchor =1 + VerticalAnchor =1 + LayoutCachedLeft =5669 + LayoutCachedTop =4081 + LayoutCachedWidth =8264 + LayoutCachedHeight =5483 + End + Begin TextBox + Locked = NotDefault + OldBorderStyle =0 + OverlapFlags =85 + TextAlign =1 + IMESentenceMode =3 + Left =5674 + Top =1251 + Width =4380 + Height =300 + TabIndex =7 + Name ="txtCurrentLetterCase" + Format ="@;;---" + ConditionalFormat = Begin + 0x01000000dc000000020000000100000000000000000000001200000001000000 , + 0xbfbfbf00ffffff000100000000000000130000003d00000001010000ba141900 , + 0xffffff0000000000000000000000000000000000000000000000000000000000 , + 0x5b0074007800740057006f00720064005d0020004900730020004e0075006c00 , + 0x6c000000000053007400720043006f006d00700028005b007400780074005700 , + 0x6f00720064005d002c005b00740078007400430075007200720065006e007400 , + 0x560061006c00750065005d002c00300029003c003e00300000000000 + End + GroupTable =1 + TopPadding =0 + GridlineWidthLeft =0 + GridlineWidthTop =0 + GridlineWidthRight =0 + GridlineWidthBottom =0 + HorizontalAnchor =1 + + LayoutCachedLeft =5674 + LayoutCachedTop =1251 + LayoutCachedWidth =10054 + LayoutCachedHeight =1551 + RowStart =2 + RowEnd =2 + ColumnEnd =1 + LayoutGroup =1 + ConditionalFormat14 = Begin + 0x010002000000010000000000000001000000bfbfbf00ffffff00110000005b00 , + 0x74007800740057006f00720064005d0020004900730020004e0075006c006c00 , + 0x0000000000000000000000000000000000000000000100000000000000010100 , + 0x00ba141900ffffff002900000053007400720043006f006d00700028005b0074 , + 0x007800740057006f00720064005d002c005b0074007800740043007500720072 , + 0x0065006e007400560061006c00750065005d002c00300029003c003e00300000 , + 0x0000000000000000000000000000000000000000 + End + GroupTable =1 + End + Begin Label + OverlapFlags =85 + TextAlign =1 + Left =5674 + Top =951 + Width =4380 + Height =300 + Name ="Label19" + Caption ="Current lettercase:" + GroupTable =1 + BottomPadding =0 + HorizontalAnchor =1 + LayoutCachedLeft =5674 + LayoutCachedTop =951 + LayoutCachedWidth =10054 + LayoutCachedHeight =1251 + RowStart =1 + RowEnd =1 + ColumnEnd =1 + LayoutGroup =1 + GroupTable =1 + End + Begin Label + OverlapFlags =85 + TextAlign =1 + Left =5674 + Top =1611 + Width =4380 + Height =300 + Name ="Label20" + Caption ="Variations:" + GroupTable =1 + BottomPadding =0 + HorizontalAnchor =1 + LayoutCachedLeft =5674 + LayoutCachedTop =1611 + LayoutCachedWidth =10054 + LayoutCachedHeight =1911 + RowStart =3 + RowEnd =3 + ColumnEnd =1 + LayoutGroup =1 + GroupTable =1 + End + Begin TextBox + Locked = NotDefault + OldBorderStyle =0 + OverlapFlags =85 + TextAlign =1 + IMESentenceMode =3 + Left =5674 + Top =3626 + Width =3403 + Height =343 + TabIndex =9 + Name ="txtSelectedLetterCase" + ControlSource ="=[lbVariations]" + Format ="@;;---" + ConditionalFormat = Begin + 0x0100000086000000010000000100000000000000000000001200000001000000 , + 0xbfbfbf00ffffff00000000000000000000000000000000000000000000000000 , + 0x0000000000000000000000000000000000000000000000000000000000000000 , + 0x5b0074007800740057006f00720064005d0020004900730020004e0075006c00 , + 0x6c0000000000 + End + GroupTable =1 + TopPadding =0 + HorizontalAnchor =1 + + LayoutCachedLeft =5674 + LayoutCachedTop =3626 + LayoutCachedWidth =9077 + LayoutCachedHeight =3969 + RowStart =6 + RowEnd =6 + LayoutGroup =1 + ConditionalFormat14 = Begin + 0x010001000000010000000000000001000000bfbfbf00ffffff00110000005b00 , + 0x74007800740057006f00720064005d0020004900730020004e0075006c006c00 , + 0x000000000000000000000000000000000000000000 + End + GroupTable =1 + End + Begin Label + OverlapFlags =85 + TextAlign =1 + Left =5674 + Top =3291 + Width =4380 + Height =300 + Name ="Label45" + Caption ="Change to:" + GroupTable =1 + TopPadding =0 + HorizontalAnchor =1 + LayoutCachedLeft =5674 + LayoutCachedTop =3291 + LayoutCachedWidth =10054 + LayoutCachedHeight =3591 + RowStart =5 + RowEnd =5 + ColumnEnd =1 + LayoutGroup =1 + GroupTable =1 + End + Begin CommandButton + Enabled = NotDefault + OverlapFlags =85 + Left =9137 + Top =3626 + Width =917 + Height =343 + TabIndex =10 + Name ="cmdChangeLetterCase" + Caption ="Commit" + OnClick ="[Event Procedure]" + GroupTable =1 + TopPadding =0 + HorizontalAnchor =1 + + LayoutCachedLeft =9137 + LayoutCachedTop =3626 + LayoutCachedWidth =10054 + LayoutCachedHeight =3969 + RowStart =6 + RowEnd =6 + ColumnStart =1 + ColumnEnd =1 + LayoutGroup =1 + ForeThemeColorIndex =0 + GridlineThemeColorIndex =1 + BackThemeColorIndex =4 + BorderThemeColorIndex =4 + HoverThemeColorIndex =4 + PressedThemeColorIndex =4 + HoverForeThemeColorIndex =0 + PressedForeThemeColorIndex =0 + GroupTable =1 + End + Begin CommandButton + OverlapFlags =85 + Left =3754 + Top =5443 + Width =1697 + Height =300 + TabIndex =13 + Name ="cmdSaveToTable" + Caption ="Export to table" + OnClick ="[Event Procedure]" + GroupTable =2 + + LayoutCachedLeft =3754 + LayoutCachedTop =5443 + LayoutCachedWidth =5451 + LayoutCachedHeight =5743 + ColumnStart =2 + ColumnEnd =2 + LayoutGroup =2 + ForeThemeColorIndex =0 + GridlineThemeColorIndex =1 + BackThemeColorIndex =4 + BorderThemeColorIndex =4 + HoverThemeColorIndex =4 + PressedThemeColorIndex =4 + HoverForeThemeColorIndex =0 + PressedForeThemeColorIndex =0 + GroupTable =2 + End + Begin CommandButton + OverlapFlags =85 + Left =1997 + Top =5443 + Width =1697 + Height =300 + TabIndex =12 + Name ="cmdLoadFromTable" + Caption ="Load from table" + OnClick ="[Event Procedure]" + GroupTable =2 + + LayoutCachedLeft =1997 + LayoutCachedTop =5443 + LayoutCachedWidth =3694 + LayoutCachedHeight =5743 + ColumnStart =1 + ColumnEnd =1 + LayoutGroup =2 + ForeThemeColorIndex =0 + GridlineThemeColorIndex =1 + BackThemeColorIndex =4 + BorderThemeColorIndex =4 + HoverThemeColorIndex =4 + PressedThemeColorIndex =4 + HoverForeThemeColorIndex =0 + PressedForeThemeColorIndex =0 + GroupTable =2 + Begin + Begin Label + OverlapFlags =85 + TextAlign =1 + Left =60 + Top =5443 + Width =1875 + Height =300 + FontSize =10 + Name ="Label56" + Caption ="Table: USysDeclDict" + GroupTable =2 + LayoutCachedLeft =60 + LayoutCachedTop =5443 + LayoutCachedWidth =1935 + LayoutCachedHeight =5743 + LayoutGroup =2 + GroupTable =2 + End + End + End + Begin Label + OverlapFlags =93 + Left =5503 + Top =5563 + Width =4525 + Height =540 + LeftMargin =57 + Name ="lblTableRecInfo" + HorizontalAnchor =2 + LayoutCachedLeft =5503 + LayoutCachedTop =5563 + LayoutCachedWidth =10028 + LayoutCachedHeight =6103 + ForeThemeColorIndex =2 + ForeTint =100.0 + End + Begin Label + OverlapFlags =215 + TextAlign =3 + Left =5494 + Top =5897 + Width =4550 + Height =223 + FontSize =8 + Name ="lblVersionInfo" + HorizontalAnchor =2 + LayoutCachedLeft =5494 + LayoutCachedTop =5897 + LayoutCachedWidth =10044 + LayoutCachedHeight =6120 + End + Begin TextBox + OverlapFlags =87 + IMESentenceMode =3 + Left =720 + Top =446 + Width =3073 + Height =300 + TabIndex =5 + Name ="filtWord" + AfterUpdate ="[Event Procedure]" + + LayoutCachedLeft =720 + LayoutCachedTop =446 + LayoutCachedWidth =3793 + LayoutCachedHeight =746 + Begin + Begin Label + OverlapFlags =95 + Left =60 + Top =446 + Width =660 + Height =300 + Name ="Label67" + Caption ="Filter:" + LayoutCachedLeft =60 + LayoutCachedTop =446 + LayoutCachedWidth =720 + LayoutCachedHeight =746 + End + End + End + Begin CommandButton + OverlapFlags =215 + Left =3981 + Top =429 + Width =1495 + Height =328 + TabIndex =4 + Name ="cmdRemoveFilter" + Caption ="remove filter" + OnClick ="[Event Procedure]" + BackStyle =0 + + LayoutCachedLeft =3981 + LayoutCachedTop =429 + LayoutCachedWidth =5476 + LayoutCachedHeight =757 + ForeThemeColorIndex =0 + GridlineThemeColorIndex =1 + Gradient =0 + BackThemeColorIndex =4 + BorderThemeColorIndex =4 + HoverThemeColorIndex =4 + PressedThemeColorIndex =4 + HoverForeThemeColorIndex =0 + PressedForeThemeColorIndex =0 + Overlaps =1 + End + Begin CommandButton + OverlapFlags =85 + Left =3754 + Top =5803 + Width =1697 + Height =317 + TabIndex =15 + Name ="cmdSaveToFile" + Caption ="Export to file" + OnClick ="[Event Procedure]" + GroupTable =2 + + LayoutCachedLeft =3754 + LayoutCachedTop =5803 + LayoutCachedWidth =5451 + LayoutCachedHeight =6120 + RowStart =1 + RowEnd =1 + ColumnStart =2 + ColumnEnd =2 + LayoutGroup =2 + ForeThemeColorIndex =0 + GridlineThemeColorIndex =1 + BackThemeColorIndex =4 + BorderThemeColorIndex =4 + HoverThemeColorIndex =4 + PressedThemeColorIndex =4 + HoverForeThemeColorIndex =0 + PressedForeThemeColorIndex =0 + GroupTable =2 + End + Begin CommandButton + OverlapFlags =85 + Left =1997 + Top =5803 + Width =1697 + Height =317 + TabIndex =14 + Name ="cmdLoadFromFile" + Caption ="Load from file" + OnClick ="[Event Procedure]" + GroupTable =2 + + LayoutCachedLeft =1997 + LayoutCachedTop =5803 + LayoutCachedWidth =3694 + LayoutCachedHeight =6120 + RowStart =1 + RowEnd =1 + ColumnStart =1 + ColumnEnd =1 + LayoutGroup =2 + ForeThemeColorIndex =0 + GridlineThemeColorIndex =1 + BackThemeColorIndex =4 + BorderThemeColorIndex =4 + HoverThemeColorIndex =4 + PressedThemeColorIndex =4 + HoverForeThemeColorIndex =0 + PressedForeThemeColorIndex =0 + GroupTable =2 + Begin + Begin Label + OverlapFlags =85 + TextAlign =1 + Left =60 + Top =5803 + Width =1875 + Height =317 + FontSize =10 + Name ="Bezeichnungsfeld71" + Caption ="File: DeclarationDict" + GroupTable =2 + LayoutCachedLeft =60 + LayoutCachedTop =5803 + LayoutCachedWidth =1935 + LayoutCachedHeight =6120 + RowStart =1 + RowEnd =1 + LayoutGroup =2 + GroupTable =2 + End + End + End + Begin CommandButton + OverlapFlags =85 + Left =9008 + Top =56 + Width =1026 + Height =397 + TabIndex =16 + Name ="cmdAPI" + Caption =" API" + OnClick ="[Event Procedure]" + ImageData = Begin + 0x2800000010000000100000000100200000000000000000000000000000000000 , + 0x000000000000000000000000000000000000000000000000b17d4a27b17d4a8d , + 0xb17d4acfb17d4affb17d4affb17d4acfb17d4a8db17d4a270000000000000000 , + 0x0000000000000000000000000000000000000000b17d4a72b17d4af6b17d4aff , + 0xb17d4affb17d4affb17d4affb17d4affb17d4affb17d4af6b17d4a7200000000 , + 0x000000000000000000000000b17d4a06b17d4ab7b17d4affb17d4affb17d4aff , + 0xb17d4affffffffffffffffffb17d4affb17d4affb17d4affb17d4affb17d4ab7 , + 0xb17d4a060000000000000000b17d4a93b17d4affb17d4affb17d4affb17d4aff , + 0xb17d4affffffffffffffffffb17d4affb17d4affb17d4affb17d4affb17d4aff , + 0xb17d4a9000000000b17d4a2db17d4afcb17d4affb17d4affb17d4affb17d4aff , + 0xb17d4affc1976effc1976effb17d4affb17d4affb17d4affb17d4affb17d4aff , + 0xb17d4afcb17d4a2db17d4a93b17d4affb17d4affb17d4affb17d4affb17d4aff , + 0xc1976effffffffffe9daccffb17d4affb17d4affb17d4affb17d4affb17d4aff , + 0xb17d4affb17d4a90b17d4adbb17d4affb17d4affb17d4affb17d4affb17d4aff , + 0xb8895bfffefdfdfff9f4f0ffba8c5fffb17d4affb17d4affb17d4affb17d4aff , + 0xb17d4affb17d4ad5b17d4af9b17d4affb17d4affb17d4affb17d4affb17d4aff , + 0xb17d4affdac2aafffffffffff4ede5ffb98b5dffb17d4affb17d4affb17d4aff , + 0xb17d4affb17d4af3b17d4af9b17d4affb17d4affb17d4affb17d4affb17d4aff , + 0xb17d4affb17d4affe0cbb7fffffffffff3ebe3ffb8895bffb17d4affb17d4aff , + 0xb17d4affb17d4af0b17d4ad8b17d4affb17d4affb17d4affb17d4affbf946aff , + 0xb17d4affb17d4affb17d4affe3d0bdffffffffffdbc3acffb17d4affb17d4aff , + 0xb17d4affb17d4ad5b17d4a90b17d4affb17d4affb27f4cfff9f6f2ffffffffff , + 0xc1976effb17d4affb17d4affd4b79bffffffffffe0cbb7ffb17d4affb17d4aff , + 0xb17d4affb17d4a8db17d4a2db17d4afcb17d4affb17d4affd9c0a8ffffffffff , + 0xf5eee8ffd2b497ffd8bda3fffbf9f6fffdfcfbffc1976effb17d4affb17d4aff , + 0xb17d4afcb17d4a2a00000000b17d4a90b17d4affb17d4affb27f4cffd9c0a8ff , + 0xfefdfdfffffffffffffffffff7f1ecffc7a27dffb17d4affb17d4affb17d4aff , + 0xb17d4a8d0000000000000000b17d4a06b17d4ab7b17d4affb17d4affb17d4aff , + 0xb78859ffc7a27dffc1976effb17d4affb17d4affb17d4affb17d4affb17d4ab7 , + 0xb17d4a0600000000000000000000000000000000b17d4a72b17d4af6b17d4aff , + 0xb17d4affb17d4affb17d4affb17d4affb17d4affb17d4af6b17d4a7200000000 , + 0x000000000000000000000000000000000000000000000000b17d4a27b17d4a8d , + 0xb17d4accb17d4afcb17d4afcb17d4accb17d4a8db17d4a270000000000000000 , + 0x0000000000000000 + End + + LayoutCachedLeft =9008 + LayoutCachedTop =56 + LayoutCachedWidth =10034 + LayoutCachedHeight =453 + PictureCaptionArrangement =5 + ForeThemeColorIndex =0 + GridlineThemeColorIndex =1 + BackThemeColorIndex =4 + BorderThemeColorIndex =4 + HoverThemeColorIndex =4 + PressedThemeColorIndex =4 + HoverForeThemeColorIndex =0 + PressedForeThemeColorIndex =0 + End + End + End + End +End +CodeBehindForm +' See "DeclarationDictForm.cls" diff --git a/source/forms/DeclarationDictForm.cls b/source/forms/DeclarationDictForm.cls new file mode 100644 index 0000000..ae68f65 --- /dev/null +++ b/source/forms/DeclarationDictForm.cls @@ -0,0 +1,396 @@ +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = True +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Compare Database +Option Explicit + +Private WithEvents m_DeclarationDict As DeclarationDict +Attribute m_DeclarationDict.VB_VarHelpID = -1 +Private m_InsertRecordset As DAO.Recordset +Private m_RunAsAPI As Boolean + +Friend Property Get ActiveDeclarationDict() As DeclarationDict + If m_DeclarationDict Is Nothing Then + Set m_DeclarationDict = New DeclarationDict + End If + Set ActiveDeclarationDict = m_DeclarationDict +End Property + +Friend Property Set ActiveDeclarationDict(ByRef DeclarationDictRef As DeclarationDict) + Set m_DeclarationDict = DeclarationDictRef +End Property + +Private Sub cmdAPI_Click() + DoCmd.OpenForm "InfoFormAPI" +End Sub + +Private Sub cmdLoadFromFile_Click() + LoadFromFile +End Sub + +Private Sub cmdLoadFromTable_Click() + LoadFromTable +End Sub + +Private Sub cmdRemoveFilter_Click() + Me.filtWord.Value = Null + RequeryDictData +End Sub + +Private Sub cmdSaveToFile_Click() + SaveToFile +End Sub + +Private Sub cmdSaveToTable_Click() + SaveToTable +End Sub + +Private Sub filtDiff_AfterUpdate() + If m_RunAsAPI Then + If Me.filtDiff.Value = 0 Then ' full list + If TableWordCount < m_DeclarationDict.Count Then + FillWordTableFromDict False + End If + End If + End If + RequeryDictData +End Sub + +Private Function TableWordCount() As Long + With CodeDb.OpenRecordset("select Count(*) from tabWords") + TableWordCount = Nz(.Fields(0), 0) + .Close + End With +End Function + +Private Sub filtWord_AfterUpdate() + RequeryDictData +End Sub + +Private Sub Form_Load() + + With CurrentApplication + Me.lblVersionInfo.Caption = .ApplicationFullName & " " & ChrW(&H2022) & " Version " & CurrentApplication.Version + End With + + CodeDb.Execute "delete from tabWords" + + If Me.OpenArgs = "RunAsApiDialog" Then + SetApiDialogMode + End If + +End Sub + +Private Sub SetApiDialogMode() + m_RunAsAPI = True + Set m_DeclarationDict = GetDeclarationDictTransferReference + FillWordTableFromDict True +End Sub + +Private Sub Form_Timer() + Me.TimerInterval = 0 + Me.lblTableRecInfo.Caption = vbNullString + Me.lblVersionInfo.Visible = True +End Sub + +Private Sub Form_Unload(Cancel As Integer) + CodeDb.Execute "delete from tabWords" +End Sub + +Private Sub cmdChangeLetterCase_Click() + ChangeLetterCase +End Sub + +Private Sub cmdUpdateDict_Click() + ActiveDeclarationDict.ImportVBProject CurrentVbProject + If Not (m_InsertRecordset Is Nothing) Then + m_InsertRecordset.Close + Set m_InsertRecordset = Nothing + End If + RequeryDictData +End Sub + +Private Sub lbDictData_AfterUpdate() + FillWordVariationsList +End Sub + +Private Sub lbVariations_AfterUpdate() + SetVariationCommitMode +End Sub + +Private Sub m_DeclarationDict_WordChanged(ByVal WordKey As String) + UpdateChangedWord WordKey +End Sub + +Private Sub UpdateChangedWord(ByVal WordKey As String) + + Static db As DAO.Database + If db Is Nothing Then + Set db = CodeDb + End If + + Dim UpdateSql As String + UpdateSql = "Update tabWords set Diff=" & SqlTools.BooleanToSqlText(m_DeclarationDict.IsWordWithChangedLetterCase(WordKey), "True") + If m_DeclarationDict.VariationsDict.Item(WordKey).Count > 1 Then + UpdateSql = UpdateSql & ", Variations =" & SqlTools.TextToSqlText(Join(m_DeclarationDict.GetWordVariations(WordKey, True), "|")) + End If + + UpdateSql = UpdateSql & " where Word=" & SqlTools.TextToSqlText(WordKey) + + db.Execute UpdateSql, dbFailOnError + +End Sub + +Private Sub m_DeclarationDict_WordInserted(ByVal WordKey As String) + + If m_InsertRecordset Is Nothing Then + Set m_InsertRecordset = CodeDb.OpenRecordset("tabWords", dbOpenDynaset, dbAppendOnly) + End If + + m_InsertRecordset.AddNew + m_InsertRecordset.Fields(0).Value = WordKey + If m_DeclarationDict.VariationsDict.Item(WordKey).Count > 1 Then + m_InsertRecordset.Fields(1).Value = Join(m_DeclarationDict.GetWordVariations(WordKey, True), "|") + End If + m_InsertRecordset.Fields(2).Value = m_DeclarationDict.IsWordWithChangedLetterCase(WordKey) + m_InsertRecordset.Update + +End Sub + +Private Sub ogViewMode_AfterUpdate() + RequeryDictData +End Sub + +Private Sub FillWordTableFromDict(Optional ByVal DiffWordsOnly As Boolean = False) + + CodeDb.Execute "delete from tabWords" + + Dim DictIndex As Long + Dim DictKey As String + Dim WordsDict As Dictionary + + If DiffWordsOnly Then + Set WordsDict = m_DeclarationDict.ToDict(False) + Else + Set WordsDict = m_DeclarationDict.WordsDict + End If + + If m_InsertRecordset Is Nothing Then + Set m_InsertRecordset = CodeDb.OpenRecordset("tabWords", dbOpenDynaset, dbAppendOnly) + End If + + For DictIndex = 0 To WordsDict.Count - 1 + DictKey = WordsDict.Keys(DictIndex) + AddRecord DictKey + Next + + RequeryDictData + +End Sub + +Private Sub AddRecord(ByVal WordKey As String) + + m_InsertRecordset.AddNew + m_InsertRecordset.Fields(0).Value = WordKey + If m_DeclarationDict.VariationsDict.Item(WordKey).Count > 1 Then + m_InsertRecordset.Fields(1).Value = Join(m_DeclarationDict.GetWordVariations(WordKey, True), "|") + End If + m_InsertRecordset.Fields(2).Value = m_DeclarationDict.IsWordWithChangedLetterCase(WordKey) + m_InsertRecordset.Update + +End Sub + +Private Sub RequeryDictData() + + ResetVariations + + Dim SelectSql As String + Dim CriteriaString As String + Dim rs As DAO.Recordset + + SelectSql = "SELECT W.Word, W.Variations FROM tabWords AS W" + + With New FilterStringBuilder + .ConfigSqlFormat "\#yyyy-mm-dd\#", "True", "*" + .Add "Diff", SQL_Boolean, SQL_Equal, CBool(Me.filtDiff.Value), , False + .Add "Word", SQL_Text, SQL_Like, Me.filtWord.Value + CriteriaString = .ToString() + End With + If Len(CriteriaString) > 0 Then + SelectSql = SelectSql & " WHERE " & CriteriaString + End If + + SelectSql = SelectSql & " ORDER BY W.Word;" + + Me.txtCurrentLetterCase.Value = Null + Me.lbDictData.Value = Null + With Me.lbDictData + .Value = Null + If .RowSource <> SelectSql Then + .RowSource = SelectSql + Else + .Requery + End If + End With + + RefreshDictInfo + +End Sub + +Private Sub RefreshDictInfo() + With ActiveDeclarationDict + Me.txtDictInfo.Value = .DiffCount & " / " & .Count + End With +End Sub + +Private Sub ResetVariations() + Me.lbVariations.RowSource = vbNullString + SetVariationCommitMode +End Sub + +Private Sub FillWordVariationsList() + + Dim lb As ListBox + Set lb = Me.lbVariations + lb.Value = Null + lb.RowSource = vbNullString + + Dim Items() As String + Items = ActiveDeclarationDict.GetWordVariations(Me.txtWord.Value) + + Dim i As Long + For i = LBound(Items) To UBound(Items) + lb.AddItem Items(i) + Next + + Me.txtCurrentLetterCase.Value = Items(UBound(Items)) + + SetVariationCommitMode + +End Sub + +Private Sub SetVariationCommitMode() + + Dim EnableChange As Boolean + + EnableChange = IsDifferentLetterCase(Nz(Me.txtCurrentLetterCase.Value, vbNullString), Nz(Me.txtSelectedLetterCase.Value, vbNullString)) + If Not EnableChange Then + EnableChange = IsDifferentLetterCase(Nz(Me.txtWord.Value, vbNullString), Nz(Me.txtSelectedLetterCase.Value, vbNullString)) + End If + + Me.cmdChangeLetterCase.Enabled = EnableChange + +End Sub + +Private Property Get IsDifferentLetterCase(ByVal String1 As String, ByVal String2 As String) As Boolean + + If Len(String1) = 0 Or Len(String2) = 0 Then + IsDifferentLetterCase = False + ElseIf StrComp(String1, String2, vbTextCompare) <> 0 Then + IsDifferentLetterCase = False + ElseIf StrComp(String1, String2, vbBinaryCompare) = 0 Then + IsDifferentLetterCase = False + Else + IsDifferentLetterCase = True + End If + +End Property + +Private Sub ChangeLetterCase() + + Dim ChangeFrom As String + Dim ChangeTo As String + + ChangeFrom = Me.txtCurrentLetterCase.Value + ChangeTo = Me.txtSelectedLetterCase.Value + + If Not IsDifferentLetterCase(ChangeFrom, ChangeTo) Then + If IsDifferentLetterCase(Me.txtWord.Value, ChangeTo) Then + SetCurrentLetterCaseAsDefault ChangeTo + End If + Exit Sub + End If + + With New CodeModulGenerator + .CreateCodemodule vbext_ct_StdModule + .InsertDeclarationLine "Private " & ChangeTo + .RemoveCodemodule + End With + + ActiveDeclarationDict.AddWord ChangeTo + + FillWordVariationsList + + Me.SetFocus + + If m_RunAsAPI Then + RequeryDictData + End If + +End Sub + +Private Sub SetCurrentLetterCaseAsDefault(ByVal ChangeTo As String) + + ActiveDeclarationDict.ChangeKeyLetterCase ChangeTo + + Dim UpdateSql As String + Dim VariationsString As String + VariationsString = Join(m_DeclarationDict.GetWordVariations(ChangeTo, True), "|") + With SqlTools + UpdateSql = "update tabWords set Word = " & .TextToSqlText(ChangeTo) & ", Variations=" & .TextToSqlText(VariationsString) & " where Word = " & .TextToSqlText(ChangeTo) + End With + CodeDb.Execute UpdateSql, dbFailOnError + + With Me.lbDictData + .Requery + .Value = ChangeTo + End With + + RefreshDictInfo + +End Sub + +Private Sub SaveToTable() + + With ActiveDeclarationDict + .SaveToTable DefaultDeclDictTableName + ShowTableRecInfo .Count & " records were inserted into " & DefaultDeclDictTableName + End With + +End Sub + +Private Sub LoadFromTable() + + Dim ErrMsg As String + + If Not ActiveDeclarationDict.LoadFromTable(DefaultDeclDictTableName, ErrMsg) Then + ShowTableRecInfo ErrMsg + Exit Sub + End If + + ShowTableRecInfo ActiveDeclarationDict.Count & " records were imported from " & DefaultDeclDictTableName + RequeryDictData + +End Sub + +Private Sub ShowTableRecInfo(ByVal Info As String) + Me.lblTableRecInfo.Caption = Info + Me.lblVersionInfo.Visible = False + Me.TimerInterval = 4000 +End Sub + +Private Sub SaveToFile() + With ActiveDeclarationDict + .ExportToFile CurrentProject.Path & "\" & CurrentProject.Name & ".DeclarationDict.txt" + ShowTableRecInfo .Count & " records were exported to " & CurrentProject.Name & ".DeclarationDict.txt" + End With +End Sub + +Private Sub LoadFromFile() + With ActiveDeclarationDict + .LoadFromFile CurrentProject.Path & "\" & CurrentProject.Name & ".DeclarationDict.txt" + ShowTableRecInfo .Count & " records were imported from " & CurrentProject.Name & ".DeclarationDict.txt" + End With + RequeryDictData +End Sub diff --git a/source/forms/InstallAddInForm.bas b/source/forms/InstallAddInForm.bas new file mode 100644 index 0000000..abb1400 --- /dev/null +++ b/source/forms/InstallAddInForm.bas @@ -0,0 +1,811 @@ +Version =20 +VersionRequired =20 +Begin Form + AllowFilters = NotDefault + PopUp = NotDefault + Modal = NotDefault + RecordSelectors = NotDefault + AutoCenter = NotDefault + NavigationButtons = NotDefault + AllowDeletions = NotDefault + DividingLines = NotDefault + AllowAdditions = NotDefault + AllowDesignChanges = NotDefault + DefaultView =0 + ScrollBars =0 + BorderStyle =3 + PictureAlignment =2 + DatasheetGridlinesBehavior =3 + GridY =10 + Width =7386 + DatasheetFontHeight =11 + ItemSuffix =335 + Left =7620 + Top =3045 + Right =20775 + Bottom =14775 + RecSrcDt = Begin + 0x956642cd6e4ee640 + End + Caption ="Install Add-in" + DatasheetFontName ="Calibri" + OnLoad ="[Event Procedure]" + FilterOnLoad =0 + OrderByOnLoad =0 + OrderByOnLoad =0 + ShowPageMargins =0 + DisplayOnSharePointSite =1 + DatasheetAlternateBackColor =15921906 + DatasheetGridlinesColor12 =0 + FitToScreen =1 + DatasheetBackThemeColorIndex =1 + BorderThemeColorIndex =3 + ThemeFontIndex =1 + ForeThemeColorIndex =0 + AlternateBackThemeColorIndex =1 + AlternateBackShade =95.0 + Begin + Begin Label + BackStyle =0 + FontSize =11 + FontName ="Calibri" + ThemeFontIndex =1 + BackThemeColorIndex =1 + BorderThemeColorIndex =0 + BorderTint =50.0 + ForeThemeColorIndex =0 + ForeTint =60.0 + GridlineThemeColorIndex =1 + GridlineShade =65.0 + End + Begin Line + BorderLineStyle =0 + Width =1701 + BorderThemeColorIndex =0 + GridlineThemeColorIndex =1 + GridlineShade =65.0 + End + Begin Image + BackStyle =0 + OldBorderStyle =0 + BorderLineStyle =0 + SizeMode =3 + PictureAlignment =2 + Width =1701 + Height =1701 + BackThemeColorIndex =1 + BorderThemeColorIndex =1 + BorderShade =65.0 + GridlineThemeColorIndex =1 + GridlineShade =65.0 + End + Begin CommandButton + Width =1701 + Height =283 + FontSize =11 + FontWeight =400 + FontName ="Calibri" + ForeThemeColorIndex =0 + ForeTint =75.0 + GridlineThemeColorIndex =1 + GridlineShade =65.0 + UseTheme =1 + Shape =1 + Gradient =12 + BackThemeColorIndex =4 + BackTint =60.0 + BorderLineStyle =0 + BorderThemeColorIndex =4 + BorderTint =60.0 + ThemeFontIndex =1 + HoverThemeColorIndex =4 + HoverTint =40.0 + PressedThemeColorIndex =4 + PressedShade =75.0 + HoverForeThemeColorIndex =0 + HoverForeTint =75.0 + PressedForeThemeColorIndex =0 + PressedForeTint =75.0 + End + Begin CheckBox + BorderLineStyle =0 + LabelX =230 + LabelY =-30 + BorderThemeColorIndex =1 + BorderShade =65.0 + GridlineThemeColorIndex =1 + GridlineShade =65.0 + End + Begin TextBox + AddColon = NotDefault + FELineBreak = NotDefault + BorderLineStyle =0 + Width =1701 + LabelX =-1701 + FontSize =11 + FontName ="Calibri" + AsianLineBreak =1 + BackThemeColorIndex =1 + BorderThemeColorIndex =1 + BorderShade =65.0 + ThemeFontIndex =1 + ForeThemeColorIndex =0 + ForeTint =75.0 + GridlineThemeColorIndex =1 + GridlineShade =65.0 + End + Begin EmptyCell + Height =240 + GridlineThemeColorIndex =1 + GridlineShade =65.0 + End + Begin Section + Height =7278 + Name ="Detailbereich" + AlternateBackThemeColorIndex =1 + AlternateBackShade =95.0 + BackThemeColorIndex =1 + Begin + Begin TextBox + Locked = NotDefault + OldBorderStyle =0 + OverlapFlags =85 + TextAlign =1 + IMESentenceMode =3 + Left =2074 + Top =3137 + Width =4740 + Height =300 + TabIndex =5 + Name ="txtAddInTitle" + FontName ="Tahoma" + GroupTable =1 + RightPadding =567 + BottomPadding =150 + ShowDatePicker =0 + + LayoutCachedLeft =2074 + LayoutCachedTop =3137 + LayoutCachedWidth =6814 + LayoutCachedHeight =3437 + RowStart =6 + RowEnd =6 + ColumnStart =1 + ColumnEnd =2 + LayoutGroup =1 + ThemeFontIndex =-1 + GroupTable =1 + Begin + Begin Label + OverlapFlags =85 + TextAlign =1 + Left =574 + Top =3137 + Width =1440 + Height =300 + Name ="lbltxtAddInName" + Caption ="Title" + FontName ="Tahoma" + GroupTable =1 + LeftPadding =57 + BottomPadding =150 + HorizontalAnchor =2 + LayoutCachedLeft =574 + LayoutCachedTop =3137 + LayoutCachedWidth =2014 + LayoutCachedHeight =3437 + RowStart =6 + RowEnd =6 + LayoutGroup =1 + ThemeFontIndex =-1 + GroupTable =1 + End + End + End + Begin TextBox + Locked = NotDefault + TabStop = NotDefault + OldBorderStyle =0 + OverlapFlags =85 + TextAlign =1 + IMESentenceMode =3 + Left =2074 + Top =574 + Width =4740 + Height =300 + TabIndex =1 + Name ="txtFileName" + FontName ="Tahoma" + GroupTable =1 + RightPadding =567 + BottomPadding =150 + ShowDatePicker =0 + + LayoutCachedLeft =2074 + LayoutCachedTop =574 + LayoutCachedWidth =6814 + LayoutCachedHeight =874 + ColumnStart =1 + ColumnEnd =2 + LayoutGroup =1 + ThemeFontIndex =-1 + GroupTable =1 + Begin + Begin Label + OverlapFlags =85 + TextAlign =1 + Left =574 + Top =574 + Width =1440 + Height =300 + Name ="lblFileName" + Caption ="File name" + FontName ="Tahoma" + GroupTable =1 + LeftPadding =57 + BottomPadding =150 + HorizontalAnchor =2 + LayoutCachedLeft =574 + LayoutCachedTop =574 + LayoutCachedWidth =2014 + LayoutCachedHeight =874 + LayoutGroup =1 + ThemeFontIndex =-1 + GroupTable =1 + End + End + End + Begin TextBox + Locked = NotDefault + OldBorderStyle =0 + OverlapFlags =85 + TextAlign =1 + IMESentenceMode =3 + Left =2074 + Top =3617 + Width =4740 + Height =300 + TabIndex =6 + Name ="txtAddInAuthor" + FontName ="Tahoma" + GroupTable =1 + RightPadding =567 + BottomPadding =150 + ShowDatePicker =0 + + LayoutCachedLeft =2074 + LayoutCachedTop =3617 + LayoutCachedWidth =6814 + LayoutCachedHeight =3917 + RowStart =7 + RowEnd =7 + ColumnStart =1 + ColumnEnd =2 + LayoutGroup =1 + ThemeFontIndex =-1 + GroupTable =1 + Begin + Begin Label + OverlapFlags =85 + TextAlign =1 + Left =574 + Top =3617 + Width =1440 + Height =300 + Name ="lblAddInAuthor" + Caption ="Author" + FontName ="Tahoma" + GroupTable =1 + LeftPadding =57 + BottomPadding =150 + HorizontalAnchor =2 + LayoutCachedLeft =574 + LayoutCachedTop =3617 + LayoutCachedWidth =2014 + LayoutCachedHeight =3917 + RowStart =7 + RowEnd =7 + LayoutGroup =1 + ThemeFontIndex =-1 + GroupTable =1 + End + End + End + Begin TextBox + Locked = NotDefault + OldBorderStyle =0 + OverlapFlags =85 + TextAlign =1 + IMESentenceMode =3 + Left =2074 + Top =4097 + Width =4740 + Height =300 + TabIndex =7 + Name ="txtAddInCompany" + FontName ="Tahoma" + GroupTable =1 + RightPadding =567 + BottomPadding =150 + ShowDatePicker =0 + + LayoutCachedLeft =2074 + LayoutCachedTop =4097 + LayoutCachedWidth =6814 + LayoutCachedHeight =4397 + RowStart =8 + RowEnd =8 + ColumnStart =1 + ColumnEnd =2 + LayoutGroup =1 + ThemeFontIndex =-1 + GroupTable =1 + Begin + Begin Label + OverlapFlags =85 + TextAlign =1 + Left =574 + Top =4097 + Width =1440 + Height =300 + Name ="lblAddInCompany" + Caption ="Company" + FontName ="Tahoma" + GroupTable =1 + LeftPadding =57 + BottomPadding =150 + HorizontalAnchor =2 + LayoutCachedLeft =574 + LayoutCachedTop =4097 + LayoutCachedWidth =2014 + LayoutCachedHeight =4397 + RowStart =8 + RowEnd =8 + LayoutGroup =1 + ThemeFontIndex =-1 + GroupTable =1 + End + End + End + Begin TextBox + Locked = NotDefault + OldBorderStyle =0 + OverlapFlags =85 + TextAlign =1 + IMESentenceMode =3 + Left =2074 + Top =4577 + Width =4740 + Height =1123 + TabIndex =8 + Name ="txtAddInComment" + FontName ="Tahoma" + GroupTable =1 + RightPadding =567 + BottomPadding =150 + VerticalAnchor =2 + ShowDatePicker =0 + + LayoutCachedLeft =2074 + LayoutCachedTop =4577 + LayoutCachedWidth =6814 + LayoutCachedHeight =5700 + RowStart =9 + RowEnd =9 + ColumnStart =1 + ColumnEnd =2 + LayoutGroup =1 + ThemeFontIndex =-1 + GroupTable =1 + Begin + Begin Label + OverlapFlags =85 + TextAlign =1 + Left =574 + Top =4577 + Width =1440 + Height =1123 + Name ="lblAddInComment" + Caption ="Comment" + FontName ="Tahoma" + GroupTable =1 + LeftPadding =57 + BottomPadding =150 + HorizontalAnchor =2 + VerticalAnchor =2 + LayoutCachedLeft =574 + LayoutCachedTop =4577 + LayoutCachedWidth =2014 + LayoutCachedHeight =5700 + RowStart =9 + RowEnd =9 + LayoutGroup =1 + ThemeFontIndex =-1 + GroupTable =1 + End + End + End + Begin CommandButton + OverlapFlags =85 + Left =574 + Top =6240 + Width =6240 + Height =450 + TabIndex =10 + Name ="cmdInstallAddIn" + Caption ="Install Add-in" + OnClick ="[Event Procedure]" + GroupTable =1 + LeftPadding =57 + RightPadding =567 + BottomPadding =567 + HorizontalAnchor =2 + + LayoutCachedLeft =574 + LayoutCachedTop =6240 + LayoutCachedWidth =6814 + LayoutCachedHeight =6690 + RowStart =11 + RowEnd =11 + ColumnEnd =2 + LayoutGroup =1 + GroupTable =1 + End + Begin TextBox + Locked = NotDefault + OldBorderStyle =0 + OverlapFlags =85 + TextAlign =1 + IMESentenceMode =3 + Left =2074 + Top =2340 + Width =4740 + Height =291 + TabIndex =4 + Name ="txtAddInStartFunction" + FontName ="Tahoma" + GroupTable =1 + RightPadding =567 + BottomPadding =150 + ShowDatePicker =0 + + LayoutCachedLeft =2074 + LayoutCachedTop =2340 + LayoutCachedWidth =6814 + LayoutCachedHeight =2631 + RowStart =4 + RowEnd =4 + ColumnStart =1 + ColumnEnd =2 + LayoutGroup =1 + ThemeFontIndex =-1 + GroupTable =1 + Begin + Begin Label + OverlapFlags =85 + TextAlign =1 + Left =574 + Top =2340 + Width =1440 + Height =291 + Name ="lblAddInStartFunction" + Caption ="Start Function" + FontName ="Tahoma" + GroupTable =1 + LeftPadding =57 + BottomPadding =150 + HorizontalAnchor =2 + LayoutCachedLeft =574 + LayoutCachedTop =2340 + LayoutCachedWidth =2014 + LayoutCachedHeight =2631 + RowStart =4 + RowEnd =4 + LayoutGroup =1 + ThemeFontIndex =-1 + GroupTable =1 + End + End + End + Begin TextBox + Locked = NotDefault + OldBorderStyle =0 + OverlapFlags =85 + TextAlign =1 + IMESentenceMode =3 + Left =2074 + Top =1860 + Width =4740 + Height =300 + TabIndex =3 + Name ="txtAddInRegPathName" + FontName ="Tahoma" + GroupTable =1 + RightPadding =567 + BottomPadding =150 + ShowDatePicker =0 + + LayoutCachedLeft =2074 + LayoutCachedTop =1860 + LayoutCachedWidth =6814 + LayoutCachedHeight =2160 + RowStart =3 + RowEnd =3 + ColumnStart =1 + ColumnEnd =2 + LayoutGroup =1 + ThemeFontIndex =-1 + GroupTable =1 + Begin + Begin Label + OverlapFlags =85 + TextAlign =1 + Left =574 + Top =1860 + Width =1440 + Height =300 + Name ="Bezeichnungsfeld105" + Caption ="Name" + FontName ="Tahoma" + GroupTable =1 + LeftPadding =57 + BottomPadding =150 + HorizontalAnchor =2 + LayoutCachedLeft =574 + LayoutCachedTop =1860 + LayoutCachedWidth =2014 + LayoutCachedHeight =2160 + RowStart =3 + RowEnd =3 + LayoutGroup =1 + ThemeFontIndex =-1 + GroupTable =1 + End + End + End + Begin Label + FontUnderline = NotDefault + OverlapFlags =85 + TextAlign =1 + Left =574 + Top =1534 + Width =6240 + Height =300 + FontWeight =700 + Name ="Bezeichnungsfeld112" + Caption ="USysRegInfo" + FontName ="Tahoma" + GroupTable =1 + LeftPadding =57 + RightPadding =567 + BottomPadding =0 + HorizontalAnchor =2 + LayoutCachedLeft =574 + LayoutCachedTop =1534 + LayoutCachedWidth =6814 + LayoutCachedHeight =1834 + RowStart =2 + RowEnd =2 + ColumnEnd =2 + LayoutGroup =1 + ThemeFontIndex =-1 + GroupTable =1 + End + Begin Label + FontUnderline = NotDefault + OverlapFlags =85 + TextAlign =1 + Left =574 + Top =2811 + Width =6240 + Height =300 + FontWeight =700 + Name ="Bezeichnungsfeld150" + Caption ="Database properties" + FontName ="Tahoma" + GroupTable =1 + LeftPadding =57 + RightPadding =567 + BottomPadding =0 + HorizontalAnchor =2 + LayoutCachedLeft =574 + LayoutCachedTop =2811 + LayoutCachedWidth =6814 + LayoutCachedHeight =3111 + RowStart =5 + RowEnd =5 + ColumnEnd =2 + LayoutGroup =1 + ThemeFontIndex =-1 + GroupTable =1 + End + Begin TextBox + Locked = NotDefault + OldBorderStyle =0 + OverlapFlags =85 + TextAlign =1 + IMESentenceMode =3 + Left =2074 + Top =1054 + Width =4740 + Height =300 + TabIndex =2 + Name ="txtAppTitle" + FontName ="Tahoma" + GroupTable =1 + RightPadding =567 + BottomPadding =150 + ShowDatePicker =0 + + LayoutCachedLeft =2074 + LayoutCachedTop =1054 + LayoutCachedWidth =6814 + LayoutCachedHeight =1354 + RowStart =1 + RowEnd =1 + ColumnStart =1 + ColumnEnd =2 + LayoutGroup =1 + ThemeFontIndex =-1 + GroupTable =1 + Begin + Begin Label + OverlapFlags =85 + TextAlign =1 + Left =574 + Top =1054 + Width =1440 + Height =300 + Name ="Label247" + Caption ="AppTitle" + FontName ="Tahoma" + GroupTable =1 + LeftPadding =57 + BottomPadding =150 + HorizontalAnchor =2 + LayoutCachedLeft =574 + LayoutCachedTop =1054 + LayoutCachedWidth =2014 + LayoutCachedHeight =1354 + RowStart =1 + RowEnd =1 + LayoutGroup =1 + ThemeFontIndex =-1 + GroupTable =1 + End + End + End + Begin CommandButton + Transparent = NotDefault + OverlapFlags =85 + Width =0 + Height =0 + Name ="sysFirst" + Caption ="-" + + End + Begin CheckBox + OverlapFlags =85 + Left =3017 + Top =5880 + Width =3797 + Height =300 + TabIndex =9 + Name ="cbCompileAddIn" + DefaultValue ="False" + GroupTable =1 + RightPadding =567 + + LayoutCachedLeft =3017 + LayoutCachedTop =5880 + LayoutCachedWidth =6814 + LayoutCachedHeight =6180 + RowStart =10 + RowEnd =10 + ColumnStart =2 + ColumnEnd =2 + LayoutGroup =1 + GroupTable =1 + Begin + Begin Label + OverlapFlags =85 + TextAlign =1 + Left =574 + Top =5880 + Width =2417 + Height =300 + ForeColor =0 + Name ="Label325" + Caption ="Install Add-in as accde" + GroupTable =1 + LeftPadding =57 + RightPadding =0 + HorizontalAnchor =2 + LayoutCachedLeft =574 + LayoutCachedTop =5880 + LayoutCachedWidth =2991 + LayoutCachedHeight =6180 + RowStart =10 + RowEnd =10 + ColumnEnd =1 + LayoutGroup =1 + ForeTint =100.0 + GroupTable =1 + End + End + End + Begin Label + OverlapFlags =85 + TextAlign =3 + Left =114 + Top =6916 + Width =7139 + Height =223 + FontSize =8 + Name ="lblVersionInfo" + HorizontalAnchor =2 + LayoutCachedLeft =114 + LayoutCachedTop =6916 + LayoutCachedWidth =7253 + LayoutCachedHeight =7139 + End + Begin CommandButton + OverlapFlags =85 + Left =6179 + Top =113 + Width =1026 + Height =397 + TabIndex =11 + Name ="cmdAPI" + Caption =" API" + OnClick ="[Event Procedure]" + HorizontalAnchor =1 + ImageData = Begin + 0x2800000010000000100000000100200000000000000000000000000000000000 , + 0x000000000000000000000000000000000000000000000000b17d4a27b17d4a8d , + 0xb17d4acfb17d4affb17d4affb17d4acfb17d4a8db17d4a270000000000000000 , + 0x0000000000000000000000000000000000000000b17d4a72b17d4af6b17d4aff , + 0xb17d4affb17d4affb17d4affb17d4affb17d4affb17d4af6b17d4a7200000000 , + 0x000000000000000000000000b17d4a06b17d4ab7b17d4affb17d4affb17d4aff , + 0xb17d4affffffffffffffffffb17d4affb17d4affb17d4affb17d4affb17d4ab7 , + 0xb17d4a060000000000000000b17d4a93b17d4affb17d4affb17d4affb17d4aff , + 0xb17d4affffffffffffffffffb17d4affb17d4affb17d4affb17d4affb17d4aff , + 0xb17d4a9000000000b17d4a2db17d4afcb17d4affb17d4affb17d4affb17d4aff , + 0xb17d4affc1976effc1976effb17d4affb17d4affb17d4affb17d4affb17d4aff , + 0xb17d4afcb17d4a2db17d4a93b17d4affb17d4affb17d4affb17d4affb17d4aff , + 0xc1976effffffffffe9daccffb17d4affb17d4affb17d4affb17d4affb17d4aff , + 0xb17d4affb17d4a90b17d4adbb17d4affb17d4affb17d4affb17d4affb17d4aff , + 0xb8895bfffefdfdfff9f4f0ffba8c5fffb17d4affb17d4affb17d4affb17d4aff , + 0xb17d4affb17d4ad5b17d4af9b17d4affb17d4affb17d4affb17d4affb17d4aff , + 0xb17d4affdac2aafffffffffff4ede5ffb98b5dffb17d4affb17d4affb17d4aff , + 0xb17d4affb17d4af3b17d4af9b17d4affb17d4affb17d4affb17d4affb17d4aff , + 0xb17d4affb17d4affe0cbb7fffffffffff3ebe3ffb8895bffb17d4affb17d4aff , + 0xb17d4affb17d4af0b17d4ad8b17d4affb17d4affb17d4affb17d4affbf946aff , + 0xb17d4affb17d4affb17d4affe3d0bdffffffffffdbc3acffb17d4affb17d4aff , + 0xb17d4affb17d4ad5b17d4a90b17d4affb17d4affb27f4cfff9f6f2ffffffffff , + 0xc1976effb17d4affb17d4affd4b79bffffffffffe0cbb7ffb17d4affb17d4aff , + 0xb17d4affb17d4a8db17d4a2db17d4afcb17d4affb17d4affd9c0a8ffffffffff , + 0xf5eee8ffd2b497ffd8bda3fffbf9f6fffdfcfbffc1976effb17d4affb17d4aff , + 0xb17d4afcb17d4a2a00000000b17d4a90b17d4affb17d4affb27f4cffd9c0a8ff , + 0xfefdfdfffffffffffffffffff7f1ecffc7a27dffb17d4affb17d4affb17d4aff , + 0xb17d4a8d0000000000000000b17d4a06b17d4ab7b17d4affb17d4affb17d4aff , + 0xb78859ffc7a27dffc1976effb17d4affb17d4affb17d4affb17d4affb17d4ab7 , + 0xb17d4a0600000000000000000000000000000000b17d4a72b17d4af6b17d4aff , + 0xb17d4affb17d4affb17d4affb17d4affb17d4affb17d4af6b17d4a7200000000 , + 0x000000000000000000000000000000000000000000000000b17d4a27b17d4a8d , + 0xb17d4accb17d4afcb17d4afcb17d4accb17d4a8db17d4a270000000000000000 , + 0x0000000000000000 + End + + LayoutCachedLeft =6179 + LayoutCachedTop =113 + LayoutCachedWidth =7205 + LayoutCachedHeight =510 + PictureCaptionArrangement =5 + End + End + End + End +End +CodeBehindForm +' See "InstallAddInForm.cls" diff --git a/source/forms/InstallAddInForm.cls b/source/forms/InstallAddInForm.cls new file mode 100644 index 0000000..b48eca8 --- /dev/null +++ b/source/forms/InstallAddInForm.cls @@ -0,0 +1,74 @@ +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = True +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Compare Database +Option Explicit + +Private m_Configuration As AddInConfiguration + +Private Property Get Configuration() As AddInConfiguration + If m_Configuration Is Nothing Then + Set m_Configuration = New AddInConfiguration + End If + Set Configuration = m_Configuration +End Property + +Private Sub cmdAPI_Click() + DoCmd.OpenForm "InfoFormAPI" +End Sub + +Private Sub Form_Load() + + With CurrentApplication + Me.lblVersionInfo.Caption = .ApplicationFullName & " " & ChrW(&H2022) & " Version " & CurrentApplication.Version + End With + + LoadDataFromConfiguration True + +End Sub + +Private Sub LoadDataFromConfiguration(ByVal LoadFromFile As Boolean) + + If LoadFromFile Then + Configuration.LoadFromCurrentFile + End If + + With Configuration + + Me.txtFileName.Value = .FileName + Me.txtAppTitle.Value = .AppTitle + + Me.txtAddInTitle.Value = .Title + Me.txtAddInAuthor.Value = .Author + Me.txtAddInCompany.Value = .Company + Me.txtAddInComment.Value = .Comments + + Me.txtAddInRegPathName.Value = .AddInRegPathName + Me.txtAddInStartFunction.Value = .AddInStartFunction + + End With + +End Sub + +Private Sub cmdInstallAddIn_Click() + + Dim Success As Boolean + Dim InstallMsg As String + + Me.sysFirst.SetFocus + Me.cmdInstallAddIn.Enabled = False + + With New AddInInstaller + Success = .InstallAddIn(m_Configuration, Nz(Me.cbCompileAddIn.Value, False), InstallMsg) + End With + + If Len(InstallMsg) > 0 Then + MsgBox InstallMsg, vbInformation, m_Configuration.AddInRegPathName + End If + + If Success Then + Application.Quit + End If + +End Sub diff --git a/source/modules/AddInConfiguration.cls b/source/modules/AddInConfiguration.cls new file mode 100644 index 0000000..0da9556 --- /dev/null +++ b/source/modules/AddInConfiguration.cls @@ -0,0 +1,340 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "AddInConfiguration" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Compare Database +Option Explicit + +Private m_AppTitle As String +Private m_Title As String +Private m_Author As String +Private m_Company As String +Private m_Comments As String + +Private m_AddInRegPathName As String +Private m_AddInRegFilePath As String +Private m_AddInStartFunction As String + +Private m_InsertRecordset As DAO.Recordset + +Public Property Get FileName() As String + If Len(m_AddInRegFilePath) > 0 Then + FileName = Mid(m_AddInRegFilePath, InStrRev(m_AddInRegFilePath, "\", , vbTextCompare) + 1) + End If +End Property + +Public Property Let FileName(ByVal NewValue As String) + If Len(NewValue) > 0 Then + AddInRegFilePath = "|ACCDIR\" & NewValue + End If +End Property + +Public Property Get AppTitle() As String + AppTitle = m_AppTitle +End Property + +Public Property Let AppTitle(ByVal NewValue As String) + m_AppTitle = NewValue +End Property + +Public Property Get Title() As String + Title = m_Title +End Property + +Public Property Let Title(ByVal NewValue As String) + m_Title = NewValue +End Property + +Public Property Get Author() As String + Author = m_Author +End Property + +Public Property Let Author(ByVal NewValue As String) + m_Author = NewValue +End Property + +Public Property Get Company() As String + Company = m_Company +End Property + +Public Property Let Company(ByVal NewValue As String) + m_Company = NewValue +End Property + +Public Property Get Comments() As String + Comments = m_Comments +End Property + +Public Property Let Comments(ByVal NewValue As String) + m_Comments = NewValue +End Property + +Public Property Get AddInRegPathName() As String + AddInRegPathName = m_AddInRegPathName +End Property + +Public Property Let AddInRegPathName(ByVal NewValue As String) + m_AddInRegPathName = NewValue +End Property + +Public Property Get AddInStartFunction() As String + AddInStartFunction = m_AddInStartFunction +End Property + +Public Property Let AddInStartFunction(ByVal NewValue As String) + m_AddInStartFunction = NewValue +End Property + +Public Property Get AddInRegFilePath() As String + AddInRegFilePath = m_AddInRegFilePath +End Property + +Public Property Let AddInRegFilePath(ByVal NewValue As String) + m_AddInRegFilePath = NewValue +End Property + +Public Sub LoadFromCurrentFile() + + If CurrentDb Is Nothing Then + Exit Sub + End If + + LoadDataFromUSysRegInfo + LoadDataFromDatabase + +End Sub + +Private Sub LoadDataFromDatabase() + + Dim db As DAO.Database + Set db = CurrentDb + + m_AppTitle = GetDbProperty(db, "AppTitle", vbNullString) + + If Len(FileName) = 0 Then + FileName = Replace(CurrentProject.Name, ".accdb", ".accda", , , vbTextCompare) + End If + + m_Title = GetDocProperty(db, "Title", vbNullString) + m_Author = GetDocProperty(db, "Author", vbNullString) + m_Company = GetDocProperty(db, "Company", vbNullString) + m_Comments = GetDocProperty(db, "Comments", vbNullString) + +End Sub + +Private Function GetDbProperty(ByVal PropDb As DAO.Database, PropertyName As String, Optional ByVal ValueIfNotExists As Variant = Null) As Variant + + On Error Resume Next + + GetDbProperty = PropDb.Properties(PropertyName) + If Err.Number <> 0 Then + Err.Clear + GetDbProperty = ValueIfNotExists + End If + +End Function + +Private Function GetDocProperty(ByVal PropDb As DAO.Database, PropertyName As String, Optional ByVal ValueIfNotExists As Variant = Null) As String + +On Error Resume Next + + Dim PropValue As String + + PropValue = PropDb.Containers("Databases").Documents("SummaryInfo").Properties(PropertyName) + If Err.Number <> 0 Then + Err.Clear + PropValue = ValueIfNotExists + End If + + GetDocProperty = PropValue + +End Function + +Private Sub LoadDataFromUSysRegInfo() +'Subkey Type ValName Value +'HKEY_CURRENT_ACCESS_PROFILE\Menu Add-Ins\ACLib Access Add-In Builder 0 +'HKEY_CURRENT_ACCESS_PROFILE\Menu Add-Ins\ACLib Access Add-In Builder 1 Expression =LoadAddIn() +'HKEY_CURRENT_ACCESS_PROFILE\Menu Add-Ins\ACLib Access Add-In Builder 1 Library |ACCDIR\ACLibAccessAddInBuilder.accda + + Dim AddInRegPathName As String + Dim AddInStartFunction As String + + Dim ValNameField As DAO.Field + Dim SubkeyField As DAO.Field + Dim ValueField As DAO.Field + + If Not Nz(DLookup("True", "MSysObjects", "[Name]='USysRegInfo'"), False) Then + Exit Sub + End If + + With CurrentDb.OpenRecordset("select * from USysRegInfo Order By Subkey, ValName") + If Not .EOF Then + + Set SubkeyField = .Fields("Subkey") + Set ValNameField = .Fields("ValName") + Set ValueField = .Fields("Value") + + Do While Not .EOF + If IsNull(ValNameField.Value) Then + With .Fields("Subkey") + m_AddInRegPathName = Mid(.Value, InStrRev(.Value, "\", , vbTextCompare) + 1) + End With + + ElseIf ValNameField.Value = "Expression" Then + m_AddInStartFunction = Nz(ValueField.Value, vbNullString) + + ElseIf ValNameField.Value = "Library" Then + m_AddInRegFilePath = Nz(ValueField.Value, vbNullString) + + End If + .MoveNext + Loop + End If + .Close + End With + +End Sub + +Public Sub SaveToCurrentFile() + + If CurrentDb Is Nothing Then + Exit Sub + End If + + SaveDataToUSysRegInfo + SaveDataToDatabase + +End Sub + +Private Sub SaveDataToDatabase() + + Dim db As DAO.Database + Set db = CurrentDb + + SetDbProperty db, "AppTitle", m_AppTitle + + SetDocProperty db, "Title", m_Title + SetDocProperty db, "Author", m_Author + SetDocProperty db, "Company", m_Company + SetDocProperty db, "Comments", m_Comments + +End Sub + +Private Sub SetDbProperty(ByVal PropDb As DAO.Database, PropertyName As String, ByVal NewValue As Variant) + +On Error GoTo HandleErr + + PropDb.Properties(PropertyName).Value = Nz(NewValue, vbNullString) + +ExitHere: + Exit Sub + +HandleErr: + If Err.Number = 3270 Then + PropDb.Properties.Append PropDb.CreateProperty(PropertyName, dbText, NewValue) + Resume ExitHere + End If + + HandleError Err.Number, Err.Source, Err.Description, aclibErrRaise + +End Sub + +Private Sub SetDocProperty(ByVal PropDb As DAO.Database, PropertyName As String, ByVal NewValue As Variant) + +On Error GoTo HandleErr + + PropDb.Containers("Databases").Documents("SummaryInfo").Properties(PropertyName).Value = Nz(NewValue, vbNullString) + +ExitHere: + Exit Sub + +HandleErr: + If Err.Number = 3270 Then + If Len(NewValue) > 0 Then + PropDb.Containers("Databases").Documents("SummaryInfo").Properties.Append PropDb.CreateProperty(PropertyName, dbText, NewValue) + End If + Resume ExitHere + End If + + HandleError Err.Number, Err.Source, Err.Description, aclibErrRaise + +End Sub + +Private Sub SaveDataToUSysRegInfo() +'Subkey Type ValName Value +'HKEY_CURRENT_ACCESS_PROFILE\Menu Add-Ins\ACLib Access Add-In Builder 0 +'HKEY_CURRENT_ACCESS_PROFILE\Menu Add-Ins\ACLib Access Add-In Builder 1 Expression =LoadAddIn() +'HKEY_CURRENT_ACCESS_PROFILE\Menu Add-Ins\ACLib Access Add-In Builder 1 Library |ACCDIR\ACLibAccessAddInBuilder.accda +' + Dim SubKey As String + Dim Expression As String + Dim Library As String + + If Len(m_AddInRegPathName) = 0 Then + MsgBox "Enter USysRegInfo-Name first!" + Exit Sub + End If + SubKey = "HKEY_CURRENT_ACCESS_PROFILE\Menu Add-Ins\" & m_AddInRegPathName + + + If Len(m_AddInStartFunction) = 0 Then + m_AddInStartFunction = "=LoadAddIn()" + End If + Expression = m_AddInStartFunction + If Left(Expression, 1) <> "=" Then + Expression = "=" & Expression + End If + If Right(Expression, 1) <> ")" Then + Expression = Expression & "()" + End If + + Library = m_AddInRegFilePath + + If Not Nz(DLookup("True", "MSysObjects", "[Name]='USysRegInfo'"), False) Then + CreateTableUSysRegInfo + End If + + Dim db As DAO.Database + Set db = CurrentDb + + db.Execute "delete from USysRegInfo where Type = 0 or Type = 1 and ValName in ('Expression', 'Library')" + + Dim rs As DAO.Recordset + Set rs = db.OpenRecordset("select * from USysRegInfo") + + InsertUSysRegInfoRecord rs, SubKey, 0, Null, Null + InsertUSysRegInfoRecord rs, SubKey, 1, "Expression", Expression + InsertUSysRegInfoRecord rs, SubKey, 1, "Library", Library + + rs.Close + +End Sub + +Private Sub InsertUSysRegInfoRecord(ByVal RegInfoRs As DAO.Recordset, ByVal SubKey As String, ByVal TypeNo As Long, ByVal ValName As Variant, ByVal NewValue As Variant) + + With RegInfoRs + .AddNew + .Fields("Subkey").Value = SubKey + .Fields("Type").Value = TypeNo + .Fields("ValName").Value = ValName + .Fields("Value").Value = NewValue + .Update + End With + +End Sub + +Private Sub CreateTableUSysRegInfo() + + Dim CreateTableDDL As String + + CreateTableDDL = "create Table USysRegInfo (" & _ + " Subkey nvarchar(255), Type int, ValName nvarchar(255), [Value] nvarchar(255))" + + CurrentProject.Connection.Execute CreateTableDDL + +End Sub diff --git a/source/modules/AddInInstaller.cls b/source/modules/AddInInstaller.cls new file mode 100644 index 0000000..5a451fb --- /dev/null +++ b/source/modules/AddInInstaller.cls @@ -0,0 +1,192 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "AddInInstaller" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Compare Database +Option Explicit + +Private m_ConfigData As AddInConfiguration + +Public Function InstallAddIn(ByVal AddInConfigData As AddInConfiguration, _ + Optional ByVal CompileAddIn As Boolean = False, _ + Optional ByRef CompletedMsg As String) As Boolean + + Dim AddInFileInstalled As Boolean + + Set m_ConfigData = AddInConfigData + + If CompileAddIn Then + AddInFileInstalled = CreateAccde(GetSourceFileFullName, GetDestFileFullName) + If AddInFileInstalled Then + CompletedMsg = "Add-In was compiled and saved in '" + GetAddInLocation + "'." + Else + CompletedMsg = "Error! Compiled file was not created." + End If + Else + DeleteAddInFiles + AddInFileInstalled = TryFileCopy(GetSourceFileFullName, GetDestFileFullName) + If AddInFileInstalled Then + CompletedMsg = "Add-In was saved in '" + GetAddInLocation + "'." + Else + CompletedMsg = "Error! File was not copied." + End If + End If + + If AddInFileInstalled = True Then + RegisterAddIn GetDestFileFullName() + End If + + InstallAddIn = AddInFileInstalled + +End Function + +Public Property Get AddInName() As String + AddInName = m_ConfigData.AddInRegPathName +End Property + +Public Property Get AddInFileName() As String + AddInFileName = m_ConfigData.FileName +End Property + +Public Property Get MsgBoxTitle() As String + MsgBoxTitle = "Install " & AddInName +End Property + +Function GetSourceFileFullName() + GetSourceFileFullName = CurrentDb.Name +End Function + +Function GetDestFileFullName() + GetDestFileFullName = GetAddInLocation & AddInFileName +End Function + +Function GetAddInLocation() + GetAddInLocation = GetAppDataLocation & "Microsoft\AddIns\" +End Function + +Function GetAppDataLocation() + GetAppDataLocation = Environ("APPDATA") & "\" +End Function + +Function DeleteAddInFiles() + + Dim DestFile As String + DestFile = GetDestFileFullName() + DeleteFile DestFile + +End Function + +Function DeleteFile(File2Delete) + If FileTools.FileExists(File2Delete) Then + Kill File2Delete + End If +End Function + +Private Function TryFileCopy(ByVal SourceFilePath As String, ByVal DestFilePath As String) As Boolean + +On Error Resume Next + + With CreateObject("Scripting.FileSystemObject") + If .FileExists(DestFilePath) Then + .DeleteFile DestFilePath, True + End If + .CopyFile SourceFilePath, DestFilePath, True + End With + + If Err.Number <> 0 Then + Err.Clear + TryFileCopy = False + Else + TryFileCopy = True + End If + +End Function + +Function CreateAccde(ByVal SourceFilePath As String, ByVal DestFilePath As String) As Boolean + + Dim FileToCompile As String + Dim AccessApp As Access.Application + + DeleteAddInFiles + + FileToCompile = DestFilePath & ".accdb" + If Not TryFileCopy(SourceFilePath, FileToCompile) Then + Exit Function + End If + + Set AccessApp = CreateObject("Access.Application") + AccessApp.SysCmd 603, (FileToCompile), (DestFilePath) + + DeleteFile FileToCompile + + CreateAccde = True + +End Function + + +'################################################## +' Register Menu Add-In + +Function RegisterAddIn(AddInFile) + + Dim AddInDb As DAO.Database + Dim rst As DAO.Recordset + Dim ItemValue As Variant + Dim wsh As Object + + Set AddInDb = DBEngine.OpenDatabase(AddInFile) + + Set wsh = CreateObject("WScript.Shell") + Set rst = AddInDb.OpenRecordset("select Subkey, ValName, Type, Value from USysRegInfo where ValName > '' Order By ValName", 8) 'dbOpenForwardOnly=8 + Do While Not rst.EOF + ItemValue = rst.Fields("Value").Value + If Len(ItemValue) > 0 Then + If InStr(1, ItemValue, "|ACCDIR") > 0 Then + ItemValue = AddInDb.Name + End If + End If + RegisterMenuAddInItem wsh, rst.Fields("Subkey").Value, rst.Fields("ValName").Value, rst.Fields("Type").Value, ItemValue + rst.MoveNext + Loop + rst.Close + + AddInDb.Close + +End Function + +Function RegisterMenuAddInItem(wsh, ByVal SubKey, ByVal ItemValName, ByVal RegType, ByVal ItemValue) + Dim RegName + RegName = GetRegistryPath(SubKey) + With wsh + If Len(ItemValName) > 0 Then + RegName = RegName & "\" & ItemValName + End If + .RegWrite RegName, ItemValue, GetRegTypeString(RegType) + End With +End Function + +Function GetRegTypeString(ByVal RegType) + Select Case RegType + Case 1 + GetRegTypeString = "REG_SZ" + Case 4 + GetRegTypeString = "REG_DWORD" + Case 0 + GetRegTypeString = vbNullString + Case Else + Err.Raise vbObjectError, "GetRegTypeString", "RegType not supported" + End Select +End Function + +Function GetRegistryPath(SubKey) + GetRegistryPath = Replace(SubKey, "HKEY_CURRENT_ACCESS_PROFILE", HkeyCurrentAccessProfileRegistryPath()) +End Function + +Function HkeyCurrentAccessProfileRegistryPath() + HkeyCurrentAccessProfileRegistryPath = "HKCU\SOFTWARE\Microsoft\Office\" & Access.Application.Version & "\Access" +End Function diff --git a/source/modules/ApplicationHandler.cls b/source/modules/ApplicationHandler.cls new file mode 100644 index 0000000..8d43f2f --- /dev/null +++ b/source/modules/ApplicationHandler.cls @@ -0,0 +1,728 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ApplicationHandler" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Attribute VB_Description = "Hauptsteuerung der Anwendung" +'--------------------------------------------------------------------------------------- +' Class: base.ApplicationHandler +'--------------------------------------------------------------------------------------- +' +' Main control of the application +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + +'--------------------------------------------------------------------------------------- +' +' base/ApplicationHandler.cls +' _codelib/license.bas +' DAO50{00025E01-0000-0000-C000-000000000046} +' +'--------------------------------------------------------------------------------------- +' +Option Compare Text +Option Explicit + +Public Enum ApplicationHandlerResumeModes + [AppResumeMode_NoResponse] = 0 ' 0 ... no answer + AppResumeMode_Completed = 1 ' Request was successfully processed + AppResumeMode_Error = 2 ' Event was accepted, but errors occurred + AppResumeMode_Cancel = 4 ' Event was accepted, but further processing should be stopped +End Enum + +Public Enum ApplicationHandlerLogType + [_AppLogType_Unknown] = 0 + AppLogType_Error = 1 + AppLogType_Tracing = 2 +End Enum + + +' Integrated extensions +Private Const EXTENSION_KEY_APPFILE As String = "AppFile" + +' Error codes +Private Const ERR_CLASS_ID As Long = 1000 + +Public Enum ApplicationHandlerErrors + AppErr_EventInterfaceMissing = vbObjectError + ERR_CLASS_ID + 1 + +End Enum + +' Constants +Private Const LOG_FILE As String = "log.txt" + +Private Const DBPROPNAME_APPTITLE As String = "AppTitle" +Private Const DBPROPNAME_APPICON As String = "AppIcon" +Private Const DBPROPNAME_USE_APPICON_FOR_FRMRPT As String = "UseAppIconForFrmRpt" +Private Const DBPROPNAME_STARTUPFORM As String = "StartUpForm" +Private Const DBPROPNAME_STARTUPMENUBAR As String = "StartUpMenuBar" + + +' Variables +Private m_AppDb As DAO.Database ' Replacement for CurrentDb or CodeDb, see Prop: AppDb + +Private m_ApplicationName As String ' Application name cache (short) +Private m_ApplicationFullName As String ' Application name cache (long) +Private m_APPLICATIONVERSION As String ' Version number to be displayed + +Private m_TransferValue As Variant +Private m_PublicPath As String ' Default directory for file explorer + +Private m_ApplicationStartFormName As String ' Form that is opened in Start method + +Private m_CustomMDIBackgroundColor As Long + +' Events +Public Event BeforeDispose(ByRef ResumeMode As ApplicationHandlerResumeModes, ByRef ResumeMessage As Variant) +Public Event AfterDispose(ByRef ResumeMode As ApplicationHandlerResumeModes, ByRef ResumeMessage As Variant) + +Public Event CheckExtension(ByVal Key As String, ByRef Exists As Boolean) + +Public Event ExtensionLookup(ByVal Key As String, ByRef ExtensionReference As Object) + +Public Event ExtensionInstance(ByVal ExtensionKey As String, ByVal InstanzKey As String, ByRef ExtensionReference As Object) + +Public Event ExtensionPropertyLookup(ByVal Key As String, ByVal PropertyName As String, _ + ByRef ResumeMode As ApplicationHandlerResumeModes, ByRef ResumeMessage As Variant) + +Public Event ExtensionProcedureCall(ByVal Key As String, ByVal ProcedureName As String, _ + ByRef ResumeMode As ApplicationHandlerResumeModes, ByRef ResumeMessage As Variant, _ + ByRef Params() As Variant) + +Public Event AppFileBeforeCreateFile( _ + ByVal sFileID As String, ByVal sFileName As String, _ + ByRef ResumeMode As ApplicationHandlerResumeModes, ByRef ResumeMessage As Variant) + +Public Event AppFileBeforeSaveFile( _ + ByVal sFileID As String, ByVal sFileName As String, ByVal SaveVersion As Boolean, _ + ByRef ResumeMode As ApplicationHandlerResumeModes, ByRef ResumeMessage As Variant, _ + ByVal ExtFieldName As String, ByVal ExtFieldValue As Variant) + +Public Event UpdateApplication( _ + ByRef ResumeMode As ApplicationHandlerResumeModes, ByRef ResumeMessage As Variant) + +Public Event CheckUpdate( _ + ByRef ResumeMode As ApplicationHandlerResumeModes, ByRef ResumeMessage As Variant) + +Public Event NewVersionExists( _ + ByRef ResumeMode As ApplicationHandlerResumeModes, ByRef ResumeMessage As Variant) + +Public Event BeforeOpenStartForm( _ + ByRef ResumeMode As ApplicationHandlerResumeModes, ByRef ResumeMessage As Variant) + +Public Event BeforeStartApplication( _ + ByRef ResumeMode As ApplicationHandlerResumeModes, ByRef ResumeMessage As Variant) + +Public Event AfterStartApplication( _ + ByRef ResumeMode As ApplicationHandlerResumeModes, ByRef ResumeMessage As Variant) + +'Tracing interface +Public Event NewAppLog( _ + ByVal LogType As ApplicationHandlerLogType, ByVal Msg As String, ByVal Args As Variant, _ + ByRef ResumeMode As ApplicationHandlerResumeModes, ByRef ResumeMessage As Variant) + +Public WriteLogToFileIfNoEventResponse As Boolean + +'--------------------------------------------------------------------------------------- +' Disposable support +'--------------------------------------------------------------------------------------- +Private m_Disposed As Boolean +Private Sub Class_Terminate() +On Error Resume Next + If Not m_Disposed Then + Dispose + End If +End Sub + +Public Sub Dispose(Optional ByRef ResumeMode As ApplicationHandlerResumeModes, Optional ByRef ResumeMessage As Variant) + + Dim TempResumeMode As ApplicationHandlerResumeModes + Dim TempResumeMessage As Variant + +On Error Resume Next + + RaiseEvent BeforeDispose(TempResumeMode, TempResumeMessage) + If TempResumeMode = AppResumeMode_Cancel Then + ResumeMode = TempResumeMode + ResumeMessage = TempResumeMessage + Exit Sub + End If + + Set m_AppDb = Nothing + + m_Disposed = True + + RaiseEvent AfterDispose(TempResumeMode, TempResumeMessage) + + ResumeMode = AppResumeMode_Completed + ResumeMessage = TempResumeMessage + +End Sub + +'--------------------------------------------------------------------------------------- +' Function: Start +'--------------------------------------------------------------------------------------- +' +' Application start +' +' Returns: +' Boolean - true = success +' +' Remarks: +' Do not confuse with initialization of ApplicationHandler. +' This procedure triggers the startup routine for the user. +' +'--------------------------------------------------------------------------------------- +Public Function Start(Optional ByRef ResumeMessage As Variant) As Boolean + + Dim CurrentStartFormName As String + Dim EventResumeMode As ApplicationHandlerResumeModes + Dim EventResumeMessage As Variant + + 'Event interface for application start + ' ... enables e.g. the execution of a login process + RaiseEvent BeforeStartApplication(EventResumeMode, EventResumeMessage) + Select Case EventResumeMode + Case ApplicationHandlerResumeModes.AppResumeMode_Cancel + 'Cancel start + ResumeMessage = EventResumeMessage + Start = False + Exit Function + Case ApplicationHandlerResumeModes.AppResumeMode_Completed + 'Start procedure was taken over from extension + Start = EventResumeMessage + Exit Function + Case ApplicationHandlerResumeModes.AppResumeMode_Error + 'Cancel with error message + Err.Raise vbObjectError, "BeforeStartApplication", EventResumeMessage + Exit Function + Case Else + 'continue + End Select + + 'Check update + If CheckVersionUpdate Then + If Me.UpdateApplication Then + Start = False + Application.Quit acQuitSaveNone + Exit Function + End If + End If + + 'Event interface for start form + '... allows changing the start form by means of extensions + ' e.g. if a user-specific form is to be opened + EventResumeMode = 0 + EventResumeMessage = Empty + RaiseEvent BeforeOpenStartForm(EventResumeMode, EventResumeMessage) + Select Case EventResumeMode + Case ApplicationHandlerResumeModes.AppResumeMode_Cancel + 'Do not open startup form + CurrentStartFormName = vbNullString + Case ApplicationHandlerResumeModes.AppResumeMode_Completed + 'Name of the StartForm was transferred + CurrentStartFormName = Nz(EventResumeMessage, vbNullString) + Case Else + CurrentStartFormName = Me.ApplicationStartFormName + End Select + + If Len(CurrentStartFormName) > 0 Then + DoCmd.OpenForm CurrentStartFormName + End If + + 'Notification about successful application start + EventResumeMode = 0 + EventResumeMessage = Empty + RaiseEvent AfterStartApplication(EventResumeMode, EventResumeMessage) + + Start = True + +End Function + + +'--------------------------------------------------------------------------------------- +' Property: ApplicationName +'--------------------------------------------------------------------------------------- +' +' Name of the current application +' +' Remarks: +' Sequence of name determination: +' 1. over set value +' 2. from title property with AppDb.Properties("AppTitle") +' 3. from filenames with AppDb.Name +' +'--------------------------------------------------------------------------------------- +Public Property Get ApplicationName() As String + If Len(m_ApplicationName) = 0 Then 'Wert aus Titel-Eigenschaft, da Konstante nicht eingestellt wurde + On Error Resume Next + m_ApplicationName = AppDb.Properties("AppTitle").Value + If Len(m_ApplicationName) = 0 Then 'Wert aus Dateinamen + m_ApplicationName = AppDb.Name + m_ApplicationName = Left$(m_ApplicationName, InStrRev(m_ApplicationName, ".") - 1) + End If + End If + ApplicationName = m_ApplicationName +End Property + +Public Property Let ApplicationName(ByVal AppName As String) + m_ApplicationName = AppName +End Property + + +'--------------------------------------------------------------------------------------- +' Property: ApplicationFullName +'--------------------------------------------------------------------------------------- +' +' Full name of the current application +' +' Remarks: +' Sequence of name determination: +' 1. over set value +' 2. with ApplicationName property +' +'--------------------------------------------------------------------------------------- +Public Property Get ApplicationFullName() As String + If Len(m_ApplicationFullName) = 0 Then 'Kurzform verwenden + m_ApplicationFullName = ApplicationName + End If + ApplicationFullName = m_ApplicationFullName +End Property + +Public Property Let ApplicationFullName(ByVal AppName As String) + m_ApplicationFullName = AppName +End Property + +'--------------------------------------------------------------------------------------- +' Property: ApplicationVersion +'--------------------------------------------------------------------------------------- +' +' Application version +' +'--------------------------------------------------------------------------------------- +Public Property Get Version() As String + + If Len(m_APPLICATIONVERSION) = 0 Then ' ... aus Properties lesen? +'/** +' @todo Versionskennung aus DB-Eigenschaften bzw. aus den Dateieigenschaften lesen +'**/ + m_APPLICATIONVERSION = "" + End If + + Version = m_APPLICATIONVERSION + +End Property + +Public Property Let Version(ByVal AppVersion As String) + m_APPLICATIONVERSION = AppVersion +End Property + +'--------------------------------------------------------------------------------------- +' Property: ApplicationStartForm +'--------------------------------------------------------------------------------------- +' +' Form opened in the method +' +'--------------------------------------------------------------------------------------- +Public Property Get ApplicationStartFormName() As String + If StrPtr(m_ApplicationStartFormName) = 0 Then ' ... aus Properties lesen? + m_ApplicationStartFormName = "" + End If + ApplicationStartFormName = m_ApplicationStartFormName +End Property + +Public Property Let ApplicationStartFormName(ByVal FormName As String) + m_ApplicationStartFormName = FormName +End Property + +'--------------------------------------------------------------------------------------- +' Property: AppDb +'--------------------------------------------------------------------------------------- +' +' Replacement for CurrentDb or CodeDb (default: CodeDb). +' +'--------------------------------------------------------------------------------------- +Public Property Get AppDb() As DAO.Database + If m_AppDb Is Nothing Then + Set m_AppDb = CodeDb + End If + Set AppDb = m_AppDb +End Property + +Friend Property Set AppDb(ByVal DbRef As DAO.Database) + Set m_AppDb = DbRef +End Property + +Public Function GetTransferValue(Optional ByVal ValueIfNull As Variant = Null, Optional ByVal NoDel As Boolean = False) As Variant + GetTransferValue = Nz(m_TransferValue, ValueIfNull) + If Not NoDel Then m_TransferValue = Null +End Function + +Public Sub SetTransferValue(ByVal NewValue As Variant) + m_TransferValue = NewValue +End Sub + +Public Property Get PublicPath() As String + PublicPath = m_PublicPath +End Property + +Friend Property Let PublicPath(ByVal NewPublicPath As String) + m_PublicPath = NewPublicPath +End Property + +Public Property Get ApplicationTitle() As String + ApplicationTitle = AppDb.Properties("AppTitle").Value +End Property + +Friend Property Let ApplicationTitle(ByVal AppTitle As String) + If Len(AppTitle) > 0 Then + SetAppDbProperty DBPROPNAME_APPTITLE, dbText, AppTitle + Else + DeleteAppDbProperty DBPROPNAME_APPTITLE + End If + Access.Application.RefreshTitleBar +End Property + +Friend Sub SetAppIcon(ByVal AppIconFile As String, Optional ByVal UseAppIconForFrmRpt As Boolean = True) + + Dim CheckVar As Boolean + + If Len(Dir$(AppIconFile)) > 0 Then + SetAppDbProperty DBPROPNAME_APPICON, dbText, AppIconFile + SetAppDbProperty DBPROPNAME_USE_APPICON_FOR_FRMRPT, dbBoolean, UseAppIconForFrmRpt + Else + '1. Prüfen ob AppFile-Erweiterung vorhanden ist + RaiseEvent CheckExtension(EXTENSION_KEY_APPFILE, CheckVar) + If CheckVar Then + CheckVar = CreateAppFile("AppIcon", AppIconFile) + End If + '2. Properties einstellen + If CheckVar Then + SetAppDbProperty DBPROPNAME_APPICON, dbText, AppIconFile + SetAppDbProperty DBPROPNAME_USE_APPICON_FOR_FRMRPT, dbBoolean, UseAppIconForFrmRpt + Else + DeleteAppDbProperty DBPROPNAME_APPICON + End If + End If + Application.RefreshTitleBar + +End Sub + +Friend Property Let StartUpForm(ByVal StartUpFormName As String) + If Len(StartUpFormName) > 0 Then + SetAppDbProperty DBPROPNAME_STARTUPFORM, dbText, "Form." & StartUpFormName + Else + DeleteAppDbProperty DBPROPNAME_STARTUPFORM + End If +End Property + +Friend Property Let StartUpMenuBar(ByVal MenuBarName As String) + If Len(MenuBarName) > 0 Then + SetAppDbProperty DBPROPNAME_STARTUPMENUBAR, dbText, MenuBarName + Else + DeleteAppDbProperty DBPROPNAME_STARTUPMENUBAR + End If +End Property + +Public Sub SetApplicationProperty(ByVal PropName As String, ByVal PropValue As Variant, Optional ByVal PropType As Long = dbText) + SetAppDbProperty PropName, PropType, PropValue +End Sub + +Private Sub SetAppDbProperty(ByVal PropName As String, ByVal PropType As Long, ByVal PropValue As Variant) + + Dim db As DAO.Database + Dim PropCol As DAO.Properties + + Set db = AppDb + Set PropCol = db.Properties + If DbPropertyExists(PropCol, PropName) Then + If Len(PropValue) = 0 Or IsNull(PropValue) Then + db.Properties.Delete PropName + Else + db.Properties(PropName) = PropValue + End If + Else + If Len(PropValue) > 0 Then + db.Properties.Append db.CreateProperty(PropName, PropType, PropValue) + End If + End If + +End Sub + +Private Sub DeleteAppDbProperty(ByVal PropName As String) + + Dim db As DAO.Database + Dim PropCol As DAO.Properties + + Set db = AppDb + Set PropCol = db.Properties + + If DbPropertyExists(PropCol, PropName) Then + PropCol.Delete PropName + End If + +End Sub + +Private Function DbPropertyExists(ByRef PropCol As DAO.Properties, ByVal PropName As String) As Boolean + + Dim prop As DAO.Property + + For Each prop In PropCol + If prop.Name = PropName Then + DbPropertyExists = True + Exit For + End If + Next + +End Function + +Private Sub WriteApplicationLogEntry(ByVal Msg As String) + + Dim LogFile As String + Dim FileNo As Long + + LogFile = CurrentProject.Path & "\" & LOG_FILE + + FileNo = FreeFile + Open LogFile For Append As FileNo + Print #FileNo, Msg + Close #FileNo + +End Sub + +Public Sub WriteLog(ByVal Msg As String, _ + Optional ByRef LogType As ApplicationHandlerLogType, _ + Optional ByVal Args As Variant, _ + Optional ByVal WriteToFileIfNoEventResponse As Boolean = False) + + Dim ResumeMode As ApplicationHandlerResumeModes + Dim EventResumeMessage As Variant + + RaiseEvent NewAppLog(LogType, Msg, Args, ResumeMode, EventResumeMessage) + + If ResumeMode = 0 And (WriteToFileIfNoEventResponse Or WriteLogToFileIfNoEventResponse Or LogType = AppLogType_Error) Then + 'no one has reacted or reported an abort => WriteApplicationLogEntry + Msg = Now() & ": " & Msg + If Len(LogType) > 0 Then + Msg = "(" & GetLogTypeString(LogType) & ") " & Msg + End If + WriteApplicationLogEntry Msg + End If + +End Sub + +Private Function GetLogTypeString(Optional ByRef LogType As ApplicationHandlerLogType) As String + Select Case LogType + Case ApplicationHandlerLogType.AppLogType_Error + GetLogTypeString = "Error" + Case ApplicationHandlerLogType.AppLogType_Tracing + GetLogTypeString = "Tracing" + Case Else + GetLogTypeString = "N/A" + End Select +End Function + +'--------------------------------------------------------------------------------------- +' Function: CreateAppFile +'--------------------------------------------------------------------------------------- +' +' Extract file from AppFile table +' +' Parameters: +' FileID - Identifier in table +' FileName - File name to be created +' +' Returns: +' Boolean - True: File was saved +' +' Remarks: +' Requires extension (addressed via event interface) +' +'--------------------------------------------------------------------------------------- +Public Function CreateAppFile(ByVal FileID As String, ByVal FileName As String) As Boolean + + Dim EventResumeMode As ApplicationHandlerResumeModes ' Return value from event interface + Dim EventResumeMessage As Variant ' Message, for termination reason (currently not used) + + '--------------------------------------------------- + ' Interface for other classes ... + ' This makes it possible that the creation of the file takes over another class + ' + EventResumeMode = 0 + RaiseEvent AppFileBeforeCreateFile(FileID, FileName, EventResumeMode, EventResumeMessage) + If EventResumeMode <> 0 Then + CreateAppFile = (EventResumeMode = ApplicationHandlerResumeModes.AppResumeMode_Completed) + Else + Err.Raise ApplicationHandlerErrors.AppErr_EventInterfaceMissing, _ + "CreateAppFile", "Auf das AppFileBeforeCreateFile-Ereignis wurde nicht reagiert" + End If + +End Function + +'--------------------------------------------------------------------------------------- +' Function: SaveAppFile +'--------------------------------------------------------------------------------------- +' +' Save file to AppFile table +' +' Parameters: +' FileID - Identifier in table +' FileName - File name to be created +' SaveVersion - (optional) Read version from file (e. g. from dll file) +' ExtFieldName - (optional) append additional data to data field: Field name +' ExtFieldValue - (optional) append additional data to data field: Value +' +' Returns: +' Boolean - True: File was saved in table +' +' Remarks: +' Requires extension (addressed via event interface) +' +'--------------------------------------------------------------------------------------- +Friend Function SaveAppFile(ByVal FileID As String, ByVal FileName As String, Optional ByVal SaveVersion As Boolean = False, _ + Optional ByVal ExtFieldName As String, Optional ByVal ExtFieldValue As Variant) As Boolean + + Dim EventResumeMode As ApplicationHandlerResumeModes ' Return value from event interface + Dim EventResumeMessage As Variant ' Message, for termination reason + + '--------------------------------------------------- + ' Event interface AppFileBeforeSaveFile + ' + EventResumeMode = 0 + RaiseEvent AppFileBeforeSaveFile(FileID, FileName, SaveVersion, EventResumeMode, EventResumeMessage, ExtFieldName, ExtFieldValue) + If EventResumeMode <> 0 Then + SaveAppFile = (EventResumeMode = ApplicationHandlerResumeModes.AppResumeMode_Completed) + Else + Err.Raise ApplicationHandlerErrors.AppErr_EventInterfaceMissing, _ + "CreateAppFile", "Auf das AppFileBeforeSaveFile-Ereignis wurde nicht reagiert" + End If + +End Function + +Public Function NewerAppVersionExists() As Boolean + + Dim ResumeMode As ApplicationHandlerResumeModes + Dim ResumeMessage As Boolean + + RaiseEvent NewVersionExists(ResumeMode, ResumeMessage) + + NewerAppVersionExists = ResumeMessage + +End Function + +Private Function CheckVersionUpdate() As Boolean +' True = Update required + + Dim EventResumeMode As ApplicationHandlerResumeModes + Dim EventResumeMessage As Variant + + RaiseEvent CheckUpdate(EventResumeMode, EventResumeMessage) + If EventResumeMode = ApplicationHandlerResumeModes.AppResumeMode_Completed Then + CheckVersionUpdate = EventResumeMessage + Else + CheckVersionUpdate = False + End If + +End Function + +'--------------------------------------------------------------------------------------- +' Property: Extensions +'--------------------------------------------------------------------------------------- +' +' Try get Reference from extension over event interface +' +' Parameters: +' ExtensionKey - Identifier of extension +' +' Returns: +' Object - True: File was saved in table +' +' Remarks: +' Requires extension (addressed via event interface) +' +'--------------------------------------------------------------------------------------- +Public Property Get Extensions(ByVal ExtensionKey As String) As Object +'Note: collection class waived .. the code is not so elegant, but one less hardly used class + +'/** +' * @todo Should you use an interface instead of late binding? +'**/ + + Dim ExtRef As Object + + RaiseEvent ExtensionLookup(ExtensionKey, ExtRef) + Set Extensions = ExtRef + +End Property + +Public Function GetExtensionInstance(ByVal ExtensionKey As String, Optional ByVal InstanceKey As String = vbNullString) As Object + + Dim ExtRef As Object + + RaiseEvent ExtensionInstance(ExtensionKey, InstanceKey, ExtRef) + Set GetExtensionInstance = ExtRef + +End Function + +Public Function GetExtensionProperty(ByVal ExtensionKey As String, ByVal PropertyName As String, _ + Optional ByVal ValueIfMissing As Variant = Empty) As Variant + + Dim EventResumeMode As ApplicationHandlerResumeModes + Dim EventResumeMessage As Variant + + RaiseEvent ExtensionPropertyLookup(ExtensionKey, PropertyName, EventResumeMode, EventResumeMessage) + + If EventResumeMode = AppResumeMode_Completed Then + GetExtensionProperty = EventResumeMessage + Else + GetExtensionProperty = ValueIfMissing + End If + +End Function + +Public Function UpdateApplication() As Boolean +' True = Close application + +' => Outsourced to extension: this makes the usage more flexible +' and everyone can choose which update method to follow + + Dim EventResumeMode As ApplicationHandlerResumeModes + Dim EventResumeMessage As Variant + + RaiseEvent UpdateApplication(EventResumeMode, EventResumeMessage) + If EventResumeMode = ApplicationHandlerResumeModes.AppResumeMode_Completed Then + UpdateApplication = EventResumeMessage + Else + UpdateApplication = False + End If + +End Function + +'--------------------------------------------------------------------------------------- +' Sub: CallExtensionProcedure +'--------------------------------------------------------------------------------------- +' +' Calling procedures from extensions +' +' Parameters: +' Key - Extension identifier +' ProcedureName - Name of the procedure to start +' ResumeMode - Return identifier +' ResumeMessage - Reply +' Params - Array for pass and return parameters +' +'--------------------------------------------------------------------------------------- +Public Sub CallExtensionProcedure(ByVal Key As String, ByVal ProcedureName As String, _ + ByRef ResumeMode As ApplicationHandlerResumeModes, ByRef ResumeMessage As Variant, _ + ByRef Params() As Variant) + + RaiseEvent ExtensionProcedureCall(Key, ProcedureName, ResumeMode, ResumeMessage, Params) + +End Sub diff --git a/source/modules/DaoTools.bas b/source/modules/DaoTools.bas new file mode 100644 index 0000000..ca0af04 --- /dev/null +++ b/source/modules/DaoTools.bas @@ -0,0 +1,99 @@ +Attribute VB_Name = "DaoTools" +Attribute VB_Description = "Hilfsfunktionen für den Umgang mit DAO" +'--------------------------------------------------------------------------------------- +' Package: data.dao.DaoTools +'--------------------------------------------------------------------------------------- +' +' Auxiliary functions for the handling of DAO +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + +'--------------------------------------------------------------------------------------- +' +' data/dao/DaoTools.bas +' _codelib/license.bas +' DAO50{00025E01-0000-0000-C000-000000000046} +' _test/data/dao/DaoToolsTests.cls +' +'--------------------------------------------------------------------------------------- +' +Option Compare Database +Option Explicit +Option Private Module + +'--------------------------------------------------------------------------------------- +' Function: TableDefExists +'--------------------------------------------------------------------------------------- +'/** +' +' Prüft ob eine Tabelle (TableDef) vorhanden ist +' +' Name der Tabelle +' DAO.Database-Referenz (falls keine angegeben wurde, wird CodeDb verwendet) +' Boolean +' +' +'**/ +'--------------------------------------------------------------------------------------- +Public Function TableDefExists(ByVal TableDefName As String, _ + Optional ByVal DbRef As DAO.Database = Nothing) As Boolean +'Man könnte auch die TableDef-Liste durchlaufen. +'Eine weitere Alternative wäre das Auswerten über cnn.OpenSchema(adSchemaTables, ...) + + TableDefExists = CheckDatabaseObjectExists(acTable, TableDefName, DbRef) + +End Function + +'--------------------------------------------------------------------------------------- +' Function: QueryDefExists +'--------------------------------------------------------------------------------------- +'/** +' +' Prüft ob eine Abfrage (QueryDef) vorhanden ist +' +' Name der Abfrage +' DAO.Database-Referenz (falls keine angegeben wurde, wird CodeDb verwendet) +' Boolean +' +' +'**/ +'--------------------------------------------------------------------------------------- +Public Function QueryDefExists(ByVal QueryDefName As String, _ + Optional ByVal DbRef As DAO.Database = Nothing) As Boolean + + QueryDefExists = CheckDatabaseObjectExists(acQuery, QueryDefName, DbRef) + +End Function + +Private Function CheckDatabaseObjectExists(ByVal ObjType As AcObjectType, ByVal ObjName As String, _ + Optional ByVal DbRef As DAO.Database = Nothing) As Boolean + + Dim rst As DAO.Recordset + Dim FilterString As String + Dim ObjectTypeFilterString As String + + If DbRef Is Nothing Then + Set DbRef = CodeDb + End If + + FilterString = "where Name = '" & Replace(ObjName, "'", "''") & "'" + + Select Case ObjType + Case AcObjectType.acTable + ObjectTypeFilterString = "Type IN (1, 4, 6)" + Case AcObjectType.acQuery + ObjectTypeFilterString = "Type =5" + End Select + + If Len(ObjectTypeFilterString) > 0 Then + FilterString = FilterString & " AND " & ObjectTypeFilterString + End If + + Set rst = DbRef.OpenRecordset("select Name from MSysObjects " & FilterString, dbOpenForwardOnly, dbReadOnly) + CheckDatabaseObjectExists = Not rst.EOF + rst.Close + +End Function diff --git a/source/modules/FilterStringBuilder.cls b/source/modules/FilterStringBuilder.cls new file mode 100644 index 0000000..ba4f894 --- /dev/null +++ b/source/modules/FilterStringBuilder.cls @@ -0,0 +1,461 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "FilterStringBuilder" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'--------------------------------------------------------------------------------------- +' Class: data.sql.FilterStringBuilder +'--------------------------------------------------------------------------------------- +' +' Create SQL criteria (filter) expression +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + +'--------------------------------------------------------------------------------------- +' +' data/FilterStringBuilder.cls +' _codelib/license.bas +' text/StringCollection.cls +' data/SqlTools.cls +' _test/data/FilterStringBuilderTests.cls +' +'--------------------------------------------------------------------------------------- +' +Option Compare Text +Option Explicit + +Private m_Items As StringCollection +Private m_SqlTool As SqlTools +Private m_DefaultConcatOperator As SqlLogicalOperator + +Private m_ConditionGroups As Collection + +Private m_SqlPrefix As String +Private m_SqlSuffix As String +Private m_ConditionPrefix As String +Private m_IgnoreSqlPreSuffixIfEmptyFilter As Boolean + +Private Const WhereReplacementText As String = "[WhereStatement]" + +Private Sub Class_Initialize() + Set m_Items = New StringCollection + m_DefaultConcatOperator = SqlLogicalOperator.SQL_And +End Sub + +Private Sub Class_Terminate() + Set m_Items = Nothing +End Sub + +'################################## +' Group: Class support + +'--------------------------------------------------------------------------------------- +' Property: Self +'--------------------------------------------------------------------------------------- +' +' Reference to Me (current instance of FilterStringBuilder class) +' +'--------------------------------------------------------------------------------------- +Public Property Get Self() As FilterStringBuilder + Set Self = Me +End Property + +'################################## +' Group: Config + +'--------------------------------------------------------------------------------------- +' Property: DefaultConcatOperator +'--------------------------------------------------------------------------------------- +' +' The default concat operator for the instance +' +'--------------------------------------------------------------------------------------- +Public Property Get DefaultConcatOperator() As SqlLogicalOperator + DefaultConcatOperator = m_DefaultConcatOperator +End Property + +Public Property Let DefaultConcatOperator(ByVal NewValue As SqlLogicalOperator) + m_DefaultConcatOperator = NewValue +End Property + +'--------------------------------------------------------------------------------------- +' Property: SqlTool +'--------------------------------------------------------------------------------------- +' +' SqlTools instance to be used (if not set, clone of global SqlTools instance is used) +' +'--------------------------------------------------------------------------------------- +Friend Property Get SqlTool() As SqlTools + If m_SqlTool Is Nothing Then + Set m_SqlTool = SqlTools.Clone + End If + Set SqlTool = m_SqlTool +End Property + +Friend Property Set SqlTool(ByVal NewRef As SqlTools) + Set m_SqlTool = NewRef +End Property + +'--------------------------------------------------------------------------------------- +' Function: ConfigSqlFormat +'--------------------------------------------------------------------------------------- +' +' Config sql text output format for specific sql dialect +' +' Parameters: +' +' SqlDateFormat - output string format for date values +' SqlBooleanTrueString - output string format for boolean values +' SqlWildCardString - wildcard string (e.g. * .. dao, % .. T-SQL) +' +'--------------------------------------------------------------------------------------- +Friend Sub ConfigSqlFormat(ByVal SqlDateFormat As String, _ + ByVal SqlBooleanTrueString As String, _ + ByVal SqlWildCardString As String) + + If m_SqlTool Is Nothing Then + Set m_SqlTool = SqlTools.NewInstance(SqlDateFormat, SqlBooleanTrueString, SqlWildCardString) + Exit Sub + End If + + With SqlTool + .SqlDateFormat = SqlDateFormat + .SqlBooleanTrueString = SqlBooleanTrueString + .SqlWildCardString = SqlWildCardString + End With + +End Sub + +'--------------------------------------------------------------------------------------- +' Function: ConfigSqlStatement +'--------------------------------------------------------------------------------------- +' +' Auxiliary function for setting SQL texts if this class is used in other filter builder classes. +' (e.g. in form.filter.FilterControlCollection) +' +' Parameters: +' +' SqlPrefix - Is placed before the FilterString for ToString output (ToString = m_SqlPrefix & FilterString & m_SqlSuffix) +' SqlSuffix - Is placed after the FilterString for ToString output (ToString = m_SqlPrefix & FilterString & m_SqlSuffix) +' ConditionPrefix - Is placed before the filter condition (but only if the filter condition is > ""). +' IgnoreSqlPreSuffixIfEmptyFilter - True: SqlPrefix + SqlSuffix are not set for empty FilterString +' +'--------------------------------------------------------------------------------------- +Friend Sub ConfigSqlStatement(ByVal SqlPrefix As String, ByVal SqlSuffix As String, _ + ByVal ConditionPrefix As String, _ + Optional ByVal IgnoreSqlPreSuffixIfEmptyFilter As Boolean = False) + m_SqlPrefix = SqlPrefix + m_SqlSuffix = SqlSuffix + m_ConditionPrefix = ConditionPrefix + m_IgnoreSqlPreSuffixIfEmptyFilter = IgnoreSqlPreSuffixIfEmptyFilter + +End Sub + +'################################## +' Group: Build Criteria + +'--------------------------------------------------------------------------------------- +' Function: Add +'--------------------------------------------------------------------------------------- +' +' Add filter criteria definition +' (uses: data.SqlTools.BuildCriteria) +' +' Parameters: +' +' FieldName - Field name in the data source to be filtered +' RelationalOperator - Relational operator (=, <=, etc.) +' Value - Filter value (can be a single value or an array of values) +' Value2 - Optional 2nd filter value (for Between) +' IgnoreValue - The value for which no filter condition is to be created. (Array transfer of values possible), Default: Null +' +'--------------------------------------------------------------------------------------- +Public Sub Add(ByVal FieldName As String, ByVal FieldDataType As SqlFieldDataType, _ + ByVal RelationalOperator As SqlRelationalOperators, _ + ByVal Value As Variant, _ + Optional ByVal Value2 As Variant = Null, _ + Optional ByVal IgnoreValue As Variant = Null) + + AddCriteria SqlTool.BuildCriteria(FieldName, FieldDataType, RelationalOperator, Value, Value2, IgnoreValue) + +End Sub + +'--------------------------------------------------------------------------------------- +' Function: AddCriteria +'--------------------------------------------------------------------------------------- +' +' Add filter criteria (String) +' +' Parameters: +' +' Criteria - Criteria string to append +' +'--------------------------------------------------------------------------------------- +Public Sub AddCriteria(ByVal Criteria As String) + If Len(Criteria) = 0 Then Exit Sub + m_Items.Add Criteria +End Sub + +'--------------------------------------------------------------------------------------- +' Function: NewConditionGroup +'--------------------------------------------------------------------------------------- +' +' New filter condition group - e.g. for Or group: ( a = 1 and (x = 2 or x >= 10) ) +' +' Parameters: +' +' ConcatOperator - [SQL_And (default), SQL_Or, SQL_CommaSeparator] .. valid within the new group +' +' Returns: +' +' FilterStringBuilder instance for new group +' +'--------------------------------------------------------------------------------------- +Public Function NewConditionGroup(ByVal ConcatOperator As SqlLogicalOperator) As FilterStringBuilder + + Dim NewBuilder As FilterStringBuilder + + Set NewBuilder = New FilterStringBuilder + Set NewBuilder.SqlTool = m_SqlTool + NewBuilder.DefaultConcatOperator = ConcatOperator + + ConditionGroups.Add NewBuilder + + Set NewConditionGroup = NewBuilder + +End Function + +Private Function AppendFilterGroupsString(ByVal BaseFilterString As String, ByVal ConcatOperator As SqlLogicalOperator, _ + Optional ByVal IgnoreDuplicateFilters As Boolean = False) As String + + Dim CondPrefix As String + Dim CondSuffix As String + + If m_ConditionGroups Is Nothing Then + AppendFilterGroupsString = BaseFilterString + Exit Function + End If + + If m_ConditionGroups.Count = 0 Then + AppendFilterGroupsString = BaseFilterString + Exit Function + End If + + If ConcatOperator <> SQL_CommaSeparator Then + CondPrefix = "(" + CondSuffix = ")" + End If + + Dim FSB As FilterStringBuilder + + With New StringCollection + + .Add BaseFilterString + + For Each FSB In m_ConditionGroups + .Add FSB.ToString() + Next + + AppendFilterGroupsString = .ToString(GetConcatOperatorString(ConcatOperator), CondPrefix, CondSuffix, True, IgnoreDuplicateFilters) + + End With + +End Function + +'--------------------------------------------------------------------------------------- +' Function: AddSubSelectCriteria +'--------------------------------------------------------------------------------------- +' +' New filter condition group for a sub select - e.g. ( a = 1 and x In (select n from tab123) ) +' +' Parameters: +' +' FieldName - Data field name to compare +' RelationalOperator - Relational operator for sub select: usually In(...) +' SelectFromText - Sql text for sub select (without where, except UseWhereReplacementTextInFromText is used) +' IgnoreIfSubSelectHasNoCriteria - True = Ignore subselect criterion if no filter values were transferred +' UseWhereReplacementTextInFromText - Replace [Where] with Where condition string ... is required for Group By-SQL, for example. +' SubSelectConcatOperator - [SQL_And (default), SQL_Or, SQL_CommaSeparator] .. valid within the new group +' +' Returns: +' +' FilterStringBuilder instance for new sub select group +' +'--------------------------------------------------------------------------------------- +Public Function AddSubSelectCriteria( _ + ByVal FieldName As String, _ + ByVal RelationalOperator As SqlRelationalOperators, _ + ByVal SelectFromText As String, _ + Optional ByVal IgnoreIfSubSelectHasNoCriteria As Boolean = False, _ + Optional ByVal UseWhereReplacementTextInFromText As Boolean = False, _ + Optional ByVal SubSelectConcatOperator As SqlLogicalOperator = SqlLogicalOperator.SQL_And _ + ) As FilterStringBuilder + + Dim NewBuilder As FilterStringBuilder + Dim SqlPrefix As String + Dim SqlSuffix As String + Dim WhereReplacementPos As Long + + SqlPrefix = FieldName & " " & SqlTools.GetRelationalOperatorString(RelationalOperator) & " (" + SqlSuffix = ")" + If UseWhereReplacementTextInFromText Then + WhereReplacementPos = InStr(1, SelectFromText, WhereReplacementText, vbTextCompare) + End If + + If WhereReplacementPos > 0 Then + SqlPrefix = SqlPrefix & Trim$(Left(SelectFromText, WhereReplacementPos - 1)) + SqlSuffix = " " & Trim$(Mid$(SelectFromText, WhereReplacementPos + Len(WhereReplacementText))) & SqlSuffix + Else + SqlPrefix = SqlPrefix & SelectFromText + End If + + Set NewBuilder = New FilterStringBuilder + NewBuilder.DefaultConcatOperator = SubSelectConcatOperator + Set NewBuilder.SqlTool = m_SqlTool + + NewBuilder.ConfigSqlStatement SqlPrefix:=SqlPrefix, SqlSuffix:=SqlSuffix, _ + ConditionPrefix:=" Where ", IgnoreSqlPreSuffixIfEmptyFilter:=IgnoreIfSubSelectHasNoCriteria + ConditionGroups.Add NewBuilder + + Set AddSubSelectCriteria = NewBuilder + +End Function + +'--------------------------------------------------------------------------------------- +' Function: AddExistsCriteria +'--------------------------------------------------------------------------------------- +' +' New filter condition group for a exits sub select - e.g. ( a = 1 and exists (select * from tab123 where t = a and y = 123) ) +' +' Parameters: +' +' SelectFromText - Sql text for sub select (without where, except UseWhereReplacementTextInFromText is used) +' IgnoreIfExistsStatementHasNoCriteria - True = Ignore subselect criterion if no filter values were transferred +' SubSelectConcatOperator - [SQL_And (default), SQL_Or, SQL_CommaSeparator] .. valid within the new group +' UseNotExists - use not exists (..): default: false = exists (...) +' +' Returns: +' +' FilterStringBuilder instance for new exists group +' +'--------------------------------------------------------------------------------------- +Public Function AddExistsCriteria( _ + ByVal SelectFromText As String, _ + Optional ByVal IgnoreIfExistsStatementHasNoCriteria As Boolean = False, _ + Optional ByVal SubSelectConcatOperator As SqlLogicalOperator = SqlLogicalOperator.SQL_And, _ + Optional ByVal UseNotExists As Boolean = False, _ + Optional ByVal UseWhereReplacementTextInFromText As Boolean = False _ + ) As FilterStringBuilder + + Dim NewBuilder As FilterStringBuilder + Dim ExistsSqlPrefix As String + Dim WhereReplacementPos As Long + Dim ExistsSqlSuffix As String + + ExistsSqlPrefix = "Exists (" + If UseNotExists Then ExistsSqlPrefix = "Not " & ExistsSqlPrefix + + If UseWhereReplacementTextInFromText Then + WhereReplacementPos = InStr(1, SelectFromText, WhereReplacementText, vbTextCompare) + End If + + If WhereReplacementPos > 0 Then + ExistsSqlSuffix = " " & Trim$(Mid$(SelectFromText, WhereReplacementPos + Len(WhereReplacementText))) & ")" + SelectFromText = Trim$(Left(SelectFromText, WhereReplacementPos - 1)) + Else + ExistsSqlSuffix = ")" + End If + + Set NewBuilder = New FilterStringBuilder + NewBuilder.DefaultConcatOperator = SubSelectConcatOperator + Set NewBuilder.SqlTool = m_SqlTool + + NewBuilder.ConfigSqlStatement SqlPrefix:=ExistsSqlPrefix & SelectFromText, _ + SqlSuffix:=ExistsSqlSuffix, ConditionPrefix:=" Where ", IgnoreSqlPreSuffixIfEmptyFilter:=IgnoreIfExistsStatementHasNoCriteria + + ConditionGroups.Add NewBuilder + + Set AddExistsCriteria = NewBuilder + +End Function + +'################################## +' Group: Output + +'--------------------------------------------------------------------------------------- +' Function: ToString +'--------------------------------------------------------------------------------------- +' +' Output criteria to String +' +' Parameters: +' +' ConcatOperator - [SQL_And (default), SQL_Or, SQL_CommaSeparator] +' IgnoreDuplicateFilters - Do not output duplicate filter criteria +' +' Returns: +' +' Criteria/filter string +' +'--------------------------------------------------------------------------------------- +Public Function ToString(Optional ByVal ConcatOperator As SqlLogicalOperator = SqlLogicalOperator.[_SQL_Default], _ + Optional ByVal IgnoreDuplicateFilters As Boolean = False) As String + + Dim FilterString As String + Dim ItemPrefix As String + Dim ItemSuffix As String + + If ConcatOperator = SqlLogicalOperator.[_SQL_Default] Then + ConcatOperator = DefaultConcatOperator + End If + + If ConcatOperator <> SQL_CommaSeparator Then + ItemPrefix = "(" + ItemSuffix = ")" + End If + + FilterString = m_Items.ToString(GetConcatOperatorString(ConcatOperator), ItemPrefix, ItemSuffix, , IgnoreDuplicateFilters) + FilterString = AppendFilterGroupsString(FilterString, ConcatOperator, IgnoreDuplicateFilters) + If Len(FilterString) > 0 Then + FilterString = m_ConditionPrefix & FilterString + End If + + If m_IgnoreSqlPreSuffixIfEmptyFilter Then + If Len(FilterString) = 0 Then + ToString = vbNullString + Exit Function + End If + End If + + ToString = m_SqlPrefix & FilterString & m_SqlSuffix + +End Function + +Private Function GetConcatOperatorString(ByVal ConcatOperator As SqlLogicalOperator) As String + + Select Case ConcatOperator + Case SqlLogicalOperator.SQL_And + GetConcatOperatorString = " And " + Case SqlLogicalOperator.SQL_Or + GetConcatOperatorString = " Or " + Case SqlLogicalOperator.SQL_CommaSeparator + GetConcatOperatorString = ", " + Case Else + + End Select + +End Function + +Private Property Get ConditionGroups() As Collection + If m_ConditionGroups Is Nothing Then + Set m_ConditionGroups = New Collection + End If + Set ConditionGroups = m_ConditionGroups +End Property diff --git a/source/modules/Module1.bas b/source/modules/Module1.bas new file mode 100644 index 0000000..65f8b1b --- /dev/null +++ b/source/modules/Module1.bas @@ -0,0 +1,18 @@ +Attribute VB_Name = "Module1" +Option Compare Database +Option Explicit + +Private Sub testn() + + Dim props As Object + Dim prop As Object + + Set props = CurrentProject.Properties + For Each prop In props + If prop.Name = "VCS Build Path" Then + props.Remove prop.Name + End If + + Next + +End Sub diff --git a/source/modules/SqlTools.cls b/source/modules/SqlTools.cls new file mode 100644 index 0000000..8b36e2b --- /dev/null +++ b/source/modules/SqlTools.cls @@ -0,0 +1,1267 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "SqlTools" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +'--------------------------------------------------------------------------------------- +' Class: data.sql.SqlTools +'--------------------------------------------------------------------------------------- +' +' Functions to build sql strings +' +' Author: +' Josef Poetzl +' +' Remarks: +' "Attribute VB_PredeclaredId = True" to enable using SqlTools without explicit instantiation. +' +' Warning: +' +'| Don't forget to set parameters for date format, boolean and wildcard for the DBMS. +' +'--------------------------------------------------------------------------------------- + +'--------------------------------------------------------------------------------------- +' +' data/SqlTools.cls +' _codelib/license.bas +' data/SqlTools.bas +' _test/data/SqlToolsTests.cls +' _test/data/SqlToolsBuildCriteriaTests.cls +' +'--------------------------------------------------------------------------------------- +' +Option Compare Text +Option Explicit + +Private Enum SqlToolsErrorNumbers + ERRNR_NOCONFIG = vbObjectError + 1 +End Enum + +' Default values for method parameters +Private Const SQL_DEFAULT_TEXTDELIMITER As String = "'" +Private Const SQL_DEFAULT_DATEFORMAT As String = "" ' "" => SqlDateFormat property will use. + ' To disable, enter value (e.g. "\#yyyy-mm\-dd\#"), + ' then this value will be used as the default entry. +Private Const SQL_DEFAULT_BOOLTRUESTRING As String = "" ' "" => SqlBooleanTrueString is used. + ' Enter value to disable (e.g. "True or 1") +Private Const SQL_DEFAULT_WILDCARD As String = "%" ' % = default value, + ' set required variations via SqlWildCardString + +Private Const SqlAndConcatString As String = " And " +Private Const SqlOrConcatString As String = " Or " + +Private m_SqlDateFormat As String +Private m_SqlBooleanTrueString As String +Private m_SqlWildCardString As String + +Private Const ResultTextIfNull As String = "Null" + +Public Enum SqlRelationalOperators + [_IgnoreAll] = &H80000000 + SQL_Not = 1 + SQL_Equal = 2 + SQL_LessThan = 4 + SQL_GreaterThan = 8 + SQL_Like = 256 + SQL_Between = 512 + SQL_In = 1024 + SQL_Add_WildCardSuffix = 2048 + SQL_Add_WildCardPrefix = 4096 + SQL_SplitValueToArray = 8192 + SQL_AllowSqlDirect = 16384 + SQL_UseLikeBehavior = 65536 +End Enum + +Public Enum SqlFieldDataType + SQL_Boolean = 1 + SQL_Numeric = 2 + SQL_Text = 3 + SQL_Date = 4 +End Enum + +Public Enum SqlLogicalOperator + [_SQL_Default] = 0 + SQL_And = 1 + SQL_Or = 2 + SQL_CommaSeparator = 3 +End Enum + +'################################## +' Group: Class support + +'--------------------------------------------------------------------------------------- +' Function: Clone +'--------------------------------------------------------------------------------------- +' +' Create a new instance with basic settings of the current instance. +' +' Parameters: +' +' NewSqlDateFormat - use this date format instead of base instance +' NewSqlBooleanTrueString - use this text for true instead of base instance +' NewSqlWildCardString - use this wildcard string instead of base instance +' +' Returns: +' +' SqlTools instance with config form base +' +' See Also: +' NewInstance +' +'--------------------------------------------------------------------------------------- +Public Function Clone(Optional ByVal NewSqlDateFormat As String = SQL_DEFAULT_DATEFORMAT, _ + Optional ByVal NewSqlBooleanTrueString As String = SQL_DEFAULT_BOOLTRUESTRING, _ + Optional ByVal NewSqlWildCardString As String = SQL_DEFAULT_WILDCARD) As SqlTools + + + If Len(NewSqlDateFormat) = 0 Then NewSqlDateFormat = Me.SqlDateFormat + If Len(NewSqlBooleanTrueString) = 0 Then NewSqlBooleanTrueString = Me.SqlBooleanTrueString + If Len(NewSqlWildCardString) = 0 Then NewSqlWildCardString = Me.SqlWildCardString + + Set Clone = NewInstance(NewSqlDateFormat, NewSqlBooleanTrueString, NewSqlWildCardString) + +End Function + +'--------------------------------------------------------------------------------------- +' Function: NewInstance +'--------------------------------------------------------------------------------------- +' +' Create a new instance +' +'--------------------------------------------------------------------------------------- +Public Function NewInstance(ByVal NewSqlDateFormat As String, _ + ByVal NewSqlBooleanTrueString As String, _ + ByVal NewSqlWildCardString As String) As SqlTools + + Dim NewInst As SqlTools + + Set NewInst = New SqlTools + With NewInst + .SqlDateFormat = NewSqlDateFormat + .SqlBooleanTrueString = NewSqlBooleanTrueString + .SqlWildCardString = NewSqlWildCardString + End With + + Set NewInstance = NewInst + +End Function + + +'################################## +' Group: SQL dialect preferences + +'--------------------------------------------------------------------------------------- +' Property: DAO +'--------------------------------------------------------------------------------------- +' +' SqlTools instance configured for DAO-SQL (Jet/ACE) +' +'--------------------------------------------------------------------------------------- +Public Property Get DAO() As SqlTools + Set DAO = Me.NewInstance("\#yyyy-mm-dd hh:nn:ss\#", "True", "*") +End Property + +'--------------------------------------------------------------------------------------- +' Property: TSql +'--------------------------------------------------------------------------------------- +' +' SqlTools instance configured for T-SQL +' +'--------------------------------------------------------------------------------------- +Public Property Get TSql() As SqlTools + Set TSql = Me.NewInstance("'yyyymmdd hh:nn:ss'", "1", "%") +End Property + +' Configuration for SQL dialect + +'--------------------------------------------------------------------------------------- +' Property: SqlWildCardString +'--------------------------------------------------------------------------------------- +' +' Wildcard character for like +' +'--------------------------------------------------------------------------------------- +Public Property Get SqlWildCardString() As String + If Len(m_SqlWildCardString) > 0 Then + SqlWildCardString = m_SqlWildCardString + Else + SqlWildCardString = SQL_DEFAULT_WILDCARD + End If +End Property + +Public Property Let SqlWildCardString(ByVal NewValue As String) + m_SqlWildCardString = NewValue +End Property + +'--------------------------------------------------------------------------------------- +' Property: SqlDateFormat +'--------------------------------------------------------------------------------------- +' +' Format for date values +' +'--------------------------------------------------------------------------------------- +Public Property Get SqlDateFormat() As String + If Len(m_SqlDateFormat) > 0 Then + SqlDateFormat = m_SqlDateFormat + Else + SqlDateFormat = SQL_DEFAULT_DATEFORMAT + End If +End Property + +Public Property Let SqlDateFormat(ByVal NewValue As String) + m_SqlDateFormat = NewValue +End Property + +'--------------------------------------------------------------------------------------- +' Property: SqlBooleanTrueString +'--------------------------------------------------------------------------------------- +' +' Boolean string in SQL statement +' +'--------------------------------------------------------------------------------------- +Public Property Get SqlBooleanTrueString() As String + If Len(m_SqlBooleanTrueString) > 0 Then + SqlBooleanTrueString = m_SqlBooleanTrueString + Else + SqlBooleanTrueString = SQL_DEFAULT_BOOLTRUESTRING + End If +End Property + +Public Property Let SqlBooleanTrueString(ByVal NewValue As String) + m_SqlBooleanTrueString = NewValue +End Property + +'################################## +' Group: BuildCriteria + +'--------------------------------------------------------------------------------------- +' Function: BuildCriteria +'--------------------------------------------------------------------------------------- +' +' Create SQL criteria string +' +' Parameters: +' FieldName - Field name in the data source to be filtered +' RelationalOperator - Relational operator (=, <=, etc.) +' FilterValue - Filter value (can be a single value or an array of values) +' FilterValue2 - Optional 2nd filter value (for Between) +' IgnoreValue - The value for which no filter condition is to be created. (Array transfer of values possible) +' +' Returns: +' SQL criteria string +' +'--------------------------------------------------------------------------------------- +Public Function BuildCriteria(ByVal FieldName As String, ByVal FieldDataType As SqlFieldDataType, _ + ByVal RelationalOperator As SqlRelationalOperators, _ + ByVal FilterValue As Variant, _ + Optional ByVal FilterValue2 As Variant = Null, _ + Optional ByVal IgnoreValue As Variant, _ + Optional ByVal DisableIgnoreNullValue As Boolean = False) As String + + Dim FilterValueString As String + Dim OperatorString As String + Dim Criteria As String + + If (RelationalOperator And [_IgnoreAll]) = [_IgnoreAll] Then + Exit Function + End If + + If IsMissing(IgnoreValue) Then + If Not DisableIgnoreNullValue Then + DisableIgnoreNullValue = True + End If + IgnoreValue = Null + End If + + ' Special cases (part 1): + If Not IsArray(FilterValue) Then + + If FilterValue = "{NULL}" Or FilterValue = "{LEER}" Or FilterValue = "{EMPTY}" Then + FilterValue = Null + DisableIgnoreNullValue = True + End If + + If FilterValue2 = "{NULL}" Or FilterValue2 = "{LEER}" Or FilterValue2 = "{EMPTY}" Then + FilterValue2 = Null + DisableIgnoreNullValue = True + End If + + If (RelationalOperator And SQL_AllowSqlDirect) = SQL_AllowSqlDirect Then + If FilterValue Like "{*@*}" Then ' Idee von Ulrich: Anwender schreibt SQL-Ausdruck + Criteria = Replace(Mid(FilterValue, 2, Len(FilterValue) - 2), "@", FieldName) + If (RelationalOperator And SQL_Not) = SQL_Not Then + Criteria = "Not " & Criteria + End If + BuildCriteria = Criteria + Exit Function + End If + End If + + End If + + If NullFilterOrEmptyFilter(FieldName, FieldDataType, RelationalOperator, Nz(FilterValue, FilterValue2), IgnoreValue, Criteria, DisableIgnoreNullValue) Then + BuildCriteria = Criteria + Exit Function + End If + + If TryBuildSplitToArrayCriteria(FieldName, FieldDataType, RelationalOperator, FilterValue, IgnoreValue, Criteria) Then + BuildCriteria = Criteria + Exit Function + End If + + 'Special cases (part 2): + If Not IsArray(FilterValue) Then + + If FieldDataType = SQL_Numeric Or FieldDataType = SQL_Date Then + + If FilterValue = "*" And RelationalOperator = SQL_Equal Then + BuildCriteria = BuildCriteria(FieldName, FieldDataType, SQL_Not, Null, Null, 0, True) + Exit Function + End If + + If IsNull(FilterValue2) Then + If TryBuildNumericSpecialCasesCriteria(FieldName, FieldDataType, RelationalOperator, FilterValue, IgnoreValue, DisableIgnoreNullValue, Criteria) Then + BuildCriteria = Criteria + Exit Function + End If + End If + + ConfigNumericSpecials RelationalOperator, FilterValue, FilterValue2 + + End If + + End If + + If TryBuildInCriteria(FieldName, FieldDataType, RelationalOperator, FilterValue, IgnoreValue, Criteria) Then + BuildCriteria = Criteria + Exit Function + End If + + If TryBuildArrayCriteria(FieldName, FieldDataType, RelationalOperator, FilterValue, IgnoreValue, Criteria) Then + BuildCriteria = Criteria + Exit Function + End If + + If TryBuildBetweenCriteria(FieldName, FieldDataType, RelationalOperator, FilterValue, FilterValue2, IgnoreValue, Criteria) Then + BuildCriteria = Criteria + Exit Function + End If + + If (RelationalOperator And SQL_Like) = SQL_Like Or (RelationalOperator And SQL_UseLikeBehavior) = SQL_UseLikeBehavior Then + If SqlWildCardString <> "*" Then + If InStr(1, FilterValue, "*") > 0 Then + FilterValue = Replace(FilterValue, "[*]", "@@@|||STAR|||@@@") + FilterValue = Replace(FilterValue, "*", SqlWildCardString) + FilterValue = Replace(FilterValue, "@@@|||STAR|||@@@", "*") + End If + End If + End If + + If (RelationalOperator And SQL_Add_WildCardSuffix) = SQL_Add_WildCardSuffix Then + If TryBuildWildCardSuffixOrPreBuildParams(FieldName, FieldDataType, RelationalOperator, FilterValue, FilterValue2, IgnoreValue, Criteria) Then + BuildCriteria = Criteria + Exit Function + End If + End If + + If (RelationalOperator And SQL_Add_WildCardPrefix) = SQL_Add_WildCardPrefix Then + If (RelationalOperator And SQL_Like) = SQL_Like Or (RelationalOperator And SQL_UseLikeBehavior) = SQL_UseLikeBehavior Then + FilterValue = SqlWildCardString & FilterValue + End If + End If + + FilterValueString = ConvertToSqlText(FilterValue, FieldDataType) + + If (RelationalOperator And SQL_Like) = SQL_Like Then + OperatorString = " Like " + If (RelationalOperator And SQL_Not) = SQL_Not Then + OperatorString = " Not" & OperatorString + End If + BuildCriteria = FieldName & OperatorString & FilterValueString + Exit Function + End If + + OperatorString = GetRelationalOperatorString(RelationalOperator) + + Criteria = FieldName & " " & OperatorString & " " & FilterValueString + + If (RelationalOperator And SQL_Not) = SQL_Not Then + '?: will this line be reached? + Criteria = "Not " & Criteria + End If + + BuildCriteria = Criteria + +End Function + +'################################## +' Group: Convert to SQL + +'--------------------------------------------------------------------------------------- +' Function: ConvertToSqlText +'--------------------------------------------------------------------------------------- +' +' Convert values to string for SQL statement assembled by VBA. +' +' Parameters: +' Value - Value to convert +' FieldDataType - Data type of the value to be converted +' +' Returns: +' String - SQL conform string +' +'--------------------------------------------------------------------------------------- +Public Function ConvertToSqlText(ByVal Value As Variant, _ + ByVal FieldDataType As SqlFieldDataType) As String + + Select Case FieldDataType + Case SqlFieldDataType.SQL_Text + ConvertToSqlText = TextToSqlText(Value) + Case SqlFieldDataType.SQL_Numeric + ConvertToSqlText = NumberToSqlText(Value) + Case SqlFieldDataType.SQL_Date + ConvertToSqlText = DateToSqlText(Value) + Case SqlFieldDataType.SQL_Boolean + ConvertToSqlText = BooleanToSqlText(Value) + Case Else + Err.Raise vbObjectError, "SqlTools.ConvertToSqlText", "FieldDataType '" & FieldDataType & "' not supported" + End Select + +End Function + +'--------------------------------------------------------------------------------------- +' Function: TextToSqlText +'--------------------------------------------------------------------------------------- +' +' Prepare text for SQL statement +' +' Parameters: +' Value - Value to convert +' Delimiter - Delimiter for text values. (In most DBMS ' is used as a delimiter). +' WithoutLeftRightDelim - Only double the boundary drawing within the values, but do not set the boundary. +' +' Returns: +' String +' +' Example: +' strSQL = "select ... from tabelle where Feld = " & TextToSqlText("ab'cd") +' => strSQL = "select ... from tabelle where Feld = 'ab''cd'" +' +'--------------------------------------------------------------------------------------- +Public Function TextToSqlText(ByVal Value As Variant, _ + Optional ByVal Delimiter As String = SQL_DEFAULT_TEXTDELIMITER, _ + Optional ByVal WithoutLeftRightDelim As Boolean = False) As String + + Dim Result As String + + If IsNull(Value) Then + TextToSqlText = ResultTextIfNull + Exit Function + End If + + Result = Replace$(Value, Delimiter, Delimiter & Delimiter) + If Not WithoutLeftRightDelim Then + Result = Delimiter & Result & Delimiter + End If + + TextToSqlText = Result + +End Function + +'--------------------------------------------------------------------------------------- +' Function: DateToSqlText +'--------------------------------------------------------------------------------------- +' +' Convert date value to string for SQL statement assembled by VBA. +' +' Parameters: +' Value - Value to convert +' FormatString - Date format (depends on DBMS!) +' +' Returns: +' String +' +'--------------------------------------------------------------------------------------- +Public Function DateToSqlText(ByVal Value As Variant, _ + Optional ByVal FormatString As String = SQL_DEFAULT_DATEFORMAT) As String + + If IsNull(Value) Then + DateToSqlText = ResultTextIfNull + Exit Function + End If + + If Not IsDate(Value) Then + Err.Raise vbObjectError, "SqlTools.DateToSqlText", "Der Wert '" & Value & "' vom Parameter Value ist kein Datumswert!" + End If + + If Len(FormatString) = 0 Then + FormatString = SqlDateFormat + If Len(FormatString) = 0 Then + Err.Raise SqlToolsErrorNumbers.ERRNR_NOCONFIG, "DateToSqlText", "date format is not defined" + End If + End If + + DateToSqlText = VBA.Format$(Value, FormatString) + +End Function + +'--------------------------------------------------------------------------------------- +' Function: NumberToSqlText +'--------------------------------------------------------------------------------------- +' +' Convert numeric value to string for SQL statement assembled by VBA. +' +' Parameters: +' Value - Value to convert +' FormatString - Date format (depends on DBMS!) +' +' Returns: +' String +' +' Remarks: +' Str function ensures ".". +' +'--------------------------------------------------------------------------------------- +Public Function NumberToSqlText(ByVal Value As Variant) As String + + Dim Result As String + + If IsNull(Value) Then + NumberToSqlText = ResultTextIfNull + Exit Function + End If + + Value = ConvertToNumeric(Value) + + Result = Trim$(Str$(Value)) + If Left(Result, 1) = "." Then + Result = "0" & Result + End If + + NumberToSqlText = Result + +End Function + +Friend Function ConvertToNumeric(ByVal Value As Variant) As Variant + + Const CheckNumber As Double = 1.23 + + Dim CheckText As String + Dim DecimalSeparatorToReplace As String + Dim NewDecimalSeparator As String + + If IsNull(Value) Then + ConvertToNumeric = Null + Exit Function + ElseIf CStr(Value) = vbNullString Then + ConvertToNumeric = Null + Exit Function + End If + + CheckText = CStr(CheckNumber) + If InStr(1, CheckText, ",") > 0 Then + DecimalSeparatorToReplace = "." + NewDecimalSeparator = "," + Else + DecimalSeparatorToReplace = "," + NewDecimalSeparator = "." + End If + + If InStr(1, Value, DecimalSeparatorToReplace) > 0 Then + Value = Replace(Value, DecimalSeparatorToReplace, NewDecimalSeparator) + Do While Value Like "*" & NewDecimalSeparator & "*" & NewDecimalSeparator & "*" + Value = Replace(Value, NewDecimalSeparator, vbNullString, 1, 1) + Loop + End If + + ConvertToNumeric = CDbl(Value) + +End Function + +'--------------------------------------------------------------------------------------- +' Function: BooleanToSqlText +'--------------------------------------------------------------------------------------- +' +' Prepare Boolean for SQL text +' +' Parameters: +' Value - Value to convert +' TrueString - String for true value (optional) +' +' Returns: +' String +' +'--------------------------------------------------------------------------------------- +Public Function BooleanToSqlText(ByVal Value As Variant, _ + Optional ByVal TrueString As String = SQL_DEFAULT_BOOLTRUESTRING) As String + + If IsNull(Value) Then + BooleanToSqlText = ResultTextIfNull + Exit Function + End If + + If CBool(Value) = True Then ' CBool(Value) to raise error 13 (type mismatch) if Value is not a boolean + If Len(TrueString) = 0 Then + TrueString = SqlBooleanTrueString + If Len(TrueString) = 0 Then + Err.Raise SqlToolsErrorNumbers.ERRNR_NOCONFIG, "BooleanToSqlText", "boolean string for true is not defined" + End If + End If + BooleanToSqlText = TrueString + Else + BooleanToSqlText = "0" + End If + +End Function + +Private Function ConfigNumericSpecials( _ + ByRef RelationalOperator As SqlRelationalOperators, _ + ByRef FilterValue As Variant, _ + ByRef FilterValue2 As Variant) + + If Left(FilterValue, 1) = "<" Then + If ((RelationalOperator And SQL_Equal) = SQL_Equal) Then + RelationalOperator = RelationalOperator - SQL_Equal + End If + RelationalOperator = RelationalOperator Or SQL_LessThan + FilterValue = Mid(FilterValue, 2) + End If + + If Left(FilterValue, 1) = ">" Then + If ((RelationalOperator And SQL_Equal) = SQL_Equal) Then + RelationalOperator = RelationalOperator - SQL_Equal + End If + RelationalOperator = RelationalOperator Or SQL_GreaterThan + FilterValue = Mid(FilterValue, 2) + End If + + If Left(FilterValue, 1) = "=" Then + RelationalOperator = RelationalOperator Or SQL_Equal + FilterValue = Mid(FilterValue, 2) + End If + + If Right(FilterValue, 1) = "*" Then + RelationalOperator = RelationalOperator Or SQL_Add_WildCardSuffix + ElseIf Right(FilterValue2, 1) = "*" Then + RelationalOperator = RelationalOperator Or SQL_Add_WildCardSuffix + End If + +End Function + +Private Function GetNextDigitNumber(ByVal Z As Variant, Optional AddToAbsoluteValue As Boolean = False) As Double + + Dim TestString As String + Dim KommaPos As Long + Dim digits As Long + Dim IsNegativ As Boolean + + Const AdditionalDecDigit As String = "1" + Const AdditionalDecDigitKorr As Double = 0.1 + + TestString = Trim(CStr(ConvertToNumeric(Replace(CStr(Z), "*", AdditionalDecDigit)))) + + If Left(TestString, 1) = "-" And (Not AddToAbsoluteValue) Then + GetNextDigitNumber = CDbl(Replace(CStr(Z), "*", vbNullString)) + Exit Function + End If + + If Left(TestString, 1) = "-" Then + IsNegativ = True + End If + + KommaPos = InStrRev(TestString, DecimalMarker) + If KommaPos = 0 Then ' next integer + If AddToAbsoluteValue And IsNegativ Then + GetNextDigitNumber = CDbl(Replace(CStr(Z), "*", vbNullString)) - 1 + Else + GetNextDigitNumber = CDbl(Replace(CStr(Z), "*", vbNullString)) + 1 + End If + Exit Function + End If + + digits = Len(TestString) - KommaPos - 1 + + If Left(TestString, 1) = "-" Then + IsNegativ = True + End If + + If AddToAbsoluteValue And IsNegativ Then + GetNextDigitNumber = CDbl(TestString) + AdditionalDecDigitKorr / 10 ^ digits - AdditionalDecDigitKorr / 10 ^ (digits - 1) + Else + GetNextDigitNumber = CDbl(TestString) + (1 - AdditionalDecDigitKorr) / 10 ^ digits + End If + +End Function + +Private Property Get DecimalMarker() As String + + Static DecChar As String + Dim CheckString As String + + If Len(DecChar) = 0 Then + CheckString = Trim(CStr(1.2)) + DecChar = Mid(CheckString, 2, 1) + End If + + DecimalMarker = DecChar + +End Property + +Private Function CharTrim(ByVal ValueToTrim As String, ByVal TrimChar As String) As String + + Dim TrimString As String + + TrimString = " " & TrimChar + Do While InStr(1, ValueToTrim, TrimString) + ValueToTrim = Replace(ValueToTrim, TrimString, TrimChar) + Loop + + TrimString = TrimChar & " " + Do While InStr(1, ValueToTrim, TrimString) + ValueToTrim = Replace(ValueToTrim, TrimString, TrimChar) + Loop + + CharTrim = ValueToTrim + +End Function + +Friend Function GetRelationalOperatorString(ByRef RelationalOperator As SqlRelationalOperators) As String + + Dim OperatorString As String + Dim op As SqlRelationalOperators + + If (RelationalOperator And SQL_In) = SQL_In Then + OperatorString = OperatorString & "In" + If (RelationalOperator And SQL_Not) = SQL_Not Then + OperatorString = "Not " & OperatorString + End If + GetRelationalOperatorString = OperatorString + Exit Function + End If + + If (RelationalOperator And SQL_Not) = SQL_Not Then + + op = RelationalOperator Xor SQL_Not + + If op = SqlRelationalOperators.SQL_Equal Then ' => "=" zu "<>" .. null berücksichtigen? + RelationalOperator = SQL_LessThan + SQL_GreaterThan + ElseIf op = SQL_GreaterThan + SQL_LessThan Then ' => "<>" zu "=" .. null berücksichtigen? + RelationalOperator = SQL_Equal + Else + RelationalOperator = RelationalOperator Xor SQL_Not + If (op And SQL_Equal) = SQL_Equal Then + RelationalOperator = RelationalOperator Xor SQL_Equal + Else + RelationalOperator = RelationalOperator Or SQL_Equal + End If + If (op And SQL_LessThan) = SQL_LessThan Then + RelationalOperator = RelationalOperator Xor SQL_LessThan + RelationalOperator = RelationalOperator Or SQL_GreaterThan + End If + If (op And SQL_GreaterThan) = SQL_GreaterThan Then + RelationalOperator = RelationalOperator Xor SQL_GreaterThan + RelationalOperator = RelationalOperator Or SQL_LessThan + End If + End If + End If + + If (RelationalOperator And SQL_LessThan) = SQL_LessThan Then + OperatorString = OperatorString & "<" + End If + + If (RelationalOperator And SQL_GreaterThan) = SQL_GreaterThan Then + OperatorString = OperatorString & ">" + End If + + If (RelationalOperator And SQL_Equal) = SQL_Equal Then + OperatorString = OperatorString & "=" + End If + + GetRelationalOperatorString = OperatorString + +End Function + +Private Function TryBuildWildCardSuffixOrPreBuildParams(ByVal FieldName As String, ByVal FieldDataType As SqlFieldDataType, _ + ByRef RelationalOperator As SqlRelationalOperators, _ + ByRef FilterValue As Variant, _ + ByRef FilterValue2 As Variant, _ + ByRef IgnoreValue As Variant, _ + ByRef Criteria As String) As Boolean + + Dim Criteria1 As String + Dim Criteria2 As String + + If (RelationalOperator And SQL_Like) = SQL_Like Or (RelationalOperator And SQL_UseLikeBehavior) = SQL_UseLikeBehavior Then + FilterValue = FilterValue & SqlWildCardString + ElseIf FieldDataType = SQL_Date Then + If (RelationalOperator And SQL_LessThan) = 0 Then ' no < therefore: >, >= or only = + If (RelationalOperator And SQL_GreaterThan) = SQL_GreaterThan Then + ' change nothing ... >= DataValue / SQL_Add_WildCardSuffix is not logical + Else ' Consider the whole day ... FieldName >= DateValue and FieldName < DateAdd("d", 1, FilterValue)) + Criteria = BuildCriteria(FieldName, FieldDataType, SQL_GreaterThan + SQL_Equal, FilterValue, , , False) & _ + SqlAndConcatString & _ + BuildCriteria(FieldName, FieldDataType, SQL_LessThan, DateAdd("d", 1, CDate(CLng(CDate(FilterValue)))), , , False) + TryBuildWildCardSuffixOrPreBuildParams = True + Exit Function + End If + Else + If (RelationalOperator And SQL_Equal) = SQL_Equal Then + RelationalOperator = RelationalOperator - SQL_Equal + End If + FilterValue = DateAdd("d", 1, CDate(CLng(CDate(FilterValue)))) + End If + ElseIf FieldDataType = SQL_Numeric Then + If (RelationalOperator And SQL_LessThan) = 0 Then ' no < daher: >, >= or only = + If (RelationalOperator And SQL_GreaterThan) = SQL_GreaterThan Then + If FilterValue Like "*[,.]*[*]" Then + FilterValue = Replace(FilterValue, "*", 0) + ElseIf FilterValue Like "*[*]" Then + FilterValue = Replace(FilterValue, "*", vbNullString) + End If + ' change nothing => >= Number / SQL_Add_WildCardSuffix is not logical + Else ' Consider following decimal values ... FieldName >= Number and FieldName < (Number + x) + If FilterValue Like "-*[*]" Then + If FilterValue Like "*[,.]*[*]" Then + FilterValue2 = Replace(FilterValue, "*", 0) + Else + FilterValue2 = Replace(FilterValue, "*", vbNullString) + End If + Criteria1 = BuildCriteria(FieldName, FieldDataType, SQL_GreaterThan, GetNextDigitNumber(FilterValue, True), , Null, False) + Criteria2 = BuildCriteria(FieldName, FieldDataType, SQL_LessThan + SQL_Equal, FilterValue2, , Null, False) + Else + Criteria1 = BuildCriteria(FieldName, FieldDataType, SQL_GreaterThan + SQL_Equal, FilterValue, , Null, False) + Criteria2 = BuildCriteria(FieldName, FieldDataType, SQL_LessThan, GetNextDigitNumber(FilterValue), , Null, False) + End If + Criteria = Criteria1 & SqlAndConcatString & Criteria2 + TryBuildWildCardSuffixOrPreBuildParams = True + Exit Function + End If + Else + If (RelationalOperator And SQL_Equal) = SQL_Equal Then + RelationalOperator = RelationalOperator - SQL_Equal + End If + FilterValue = GetNextDigitNumber(FilterValue) + End If + End If + +End Function + +Private Function TryBuildNumericSpecialCasesCriteria(ByRef FieldName As String, ByVal FieldDataType As SqlFieldDataType, _ + ByRef RelationalOperator As SqlRelationalOperators, _ + ByRef FilterValue As Variant, _ + ByRef IgnoreValue As Variant, _ + ByRef DisableIgnoreNullValue As Boolean, _ + ByRef Criteria As String) As Boolean + + Dim CriteriaBuild As Boolean + Dim TempArr() As String + + Const FilterValue2 As Variant = Null + + If VarType(FilterValue) = vbString Then + FilterValue = Trim(FilterValue) + End If + + If FilterValue Like "[0-9]*..*[0-9]*" Or FilterValue Like "[+-][0-9]*..*[0-9]*" Then + TempArr = Split(FilterValue, "..") + Criteria = BuildCriteria(FieldName, FieldDataType, SQL_Between, Trim(TempArr(0)), Trim(TempArr(1)), IgnoreValue, DisableIgnoreNullValue) + CriteriaBuild = True + ElseIf FilterValue Like "[0-9]*-*[0-9]*" Or FilterValue Like "[+-][0-9]*-*[0-9]*" Then ' convert to a..b + If Left(FilterValue, 1) = "-" Then + FilterValue = "{M}" & Mid(FilterValue, 2) + End If + FilterValue = Replace(FilterValue, " ", " ") + FilterValue = Replace(FilterValue, "- -", "--") + FilterValue = Replace(FilterValue, "--", "-{M}") + FilterValue = Replace(FilterValue, "-", "..") + FilterValue = Replace(FilterValue, "{M}", "-") + + TempArr = Split(FilterValue, "..") + Criteria = BuildCriteria(FieldName, FieldDataType, SQL_Between, Trim(TempArr(0)), Trim(TempArr(1)), IgnoreValue, DisableIgnoreNullValue) + CriteriaBuild = True + ElseIf FilterValue Like "*[0-9]" & DecimalMarker & "*[*]" Then + If (RelationalOperator And SQL_Add_WildCardSuffix) = 0 Then + Criteria = BuildCriteria(FieldName, FieldDataType, RelationalOperator + SQL_Add_WildCardSuffix, FilterValue, FilterValue2, IgnoreValue, DisableIgnoreNullValue) + CriteriaBuild = True + End If + End If + + TryBuildNumericSpecialCasesCriteria = CriteriaBuild + +End Function + + +Private Function TryBuildSplitToArrayCriteria(ByRef FieldName As String, ByVal FieldDataType As SqlFieldDataType, _ + ByRef RelationalOperator As SqlRelationalOperators, _ + ByRef FilterValue As Variant, _ + ByRef IgnoreValue As Variant, _ + ByRef Criteria As String) As Boolean + + Dim ValueSplitted As Boolean + Dim CriteriaConcatString As String + + If (RelationalOperator And SQL_SplitValueToArray) = SQL_SplitValueToArray Then + + RelationalOperator = RelationalOperator Xor SQL_SplitValueToArray + + If InStr(1, FilterValue, SqlOrConcatString, vbTextCompare) > 0 Then + FilterValue = Replace(FilterValue, SqlOrConcatString, ";") + End If + + If InStr(1, FilterValue, SqlAndConcatString, vbTextCompare) > 0 Then + FilterValue = Replace(FilterValue, SqlAndConcatString, "+") + End If + + If InStr(1, FilterValue, ";") > 0 Then + If InStr(1, FilterValue, "+") > 0 Then + RelationalOperator = RelationalOperator Or SQL_SplitValueToArray + End If + CriteriaConcatString = SqlOrConcatString + FilterValue = Split(CharTrim(FilterValue, ";"), ";") + ValueSplitted = True + ElseIf InStr(1, FilterValue, "+") > 0 Then + CriteriaConcatString = SqlAndConcatString + FilterValue = Split(CharTrim(FilterValue, "+"), "+") + ValueSplitted = True + End If + End If + + If ValueSplitted Then + + If CriteriaConcatString = SqlOrConcatString Then + If TryBuildInCriteria(FieldName, FieldDataType, RelationalOperator, FilterValue, IgnoreValue, Criteria) Then + Exit Function + End If + End If + + TryBuildSplitToArrayCriteria = TryBuildArrayCriteria(FieldName, FieldDataType, RelationalOperator, FilterValue, IgnoreValue, Criteria, CriteriaConcatString) + + End If + +End Function + + +Private Function TryBuildArrayCriteria(ByRef FieldName As String, ByVal FieldDataType As SqlFieldDataType, _ + ByRef RelationalOperator As SqlRelationalOperators, _ + ByRef FilterValue As Variant, _ + ByRef IgnoreValue As Variant, _ + ByRef Criteria As String, _ + Optional ByVal CriteriaConcatString As String = SqlOrConcatString) As Boolean + Dim itm As Variant + Dim ItmCriteria As String + + Dim arrFilterValue() As Variant + + If Not IsArray(FilterValue) Then + Exit Function + End If + + 'Connect criteria via Or + For Each itm In FilterValue + ItmCriteria = BuildCriteria(FieldName, FieldDataType, RelationalOperator, itm, , IgnoreValue, False) + If Len(ItmCriteria) > 0 Then + Criteria = Criteria & CriteriaConcatString & ItmCriteria + End If + Next + If Len(Criteria) > 0 Then + Criteria = Mid(Criteria, Len(CriteriaConcatString) + 1) ' 1. Or wegschneiden + End If + + TryBuildArrayCriteria = True + +End Function + +Private Function TryBuildInCriteria(ByRef FieldName As String, ByVal FieldDataType As SqlFieldDataType, _ + ByRef RelationalOperator As SqlRelationalOperators, _ + ByRef FilterValue As Variant, _ + ByRef IgnoreValue As Variant, _ + ByRef Criteria As String) As Boolean + + Dim OperatorString As String + Dim FilterValueString As String + + If (RelationalOperator And SQL_In) = 0 Then + Exit Function + End If + + If IsArray(FilterValue) Then + FilterValueString = GetValueArrayString(FilterValue, FieldDataType, ",", IgnoreValue) + ElseIf VarType(FilterValue) = vbString Then + If FieldDataType = SQL_Text Then + If Left(FilterValue, 1) = "'" Then ' Is already as SQL text in the FilterString + FilterValueString = FilterValue + Else + FilterValueString = ConvertToSqlText(FilterValue, FieldDataType) + End If + Else + FilterValueString = FilterValue ' Value is already in the listing as a string + End If + Else + FilterValueString = ConvertToSqlText(FilterValue, FieldDataType) + End If + + OperatorString = " In " + If (RelationalOperator And SQL_Not) = SQL_Not Then + OperatorString = " Not" & OperatorString + End If + + If Len(FilterValueString) > 0 Then + + If RemoveNullFromInValueString(FilterValueString) Then + Criteria = FieldName & " Is Null" + If Len(FilterValueString) > 0 Then + Criteria = Criteria & " Or " & FieldName & OperatorString & "(" & FilterValueString & ")" + End If + Else + Criteria = FieldName & OperatorString & "(" & FilterValueString & ")" + End If + + End If + + TryBuildInCriteria = True + +End Function + +Private Function TryBuildBetweenCriteria(ByRef FieldName As String, ByVal FieldDataType As SqlFieldDataType, _ + ByRef RelationalOperator As SqlRelationalOperators, _ + ByRef FilterValue As Variant, _ + ByRef FilterValue2 As Variant, _ + ByRef IgnoreValue As Variant, _ + ByRef Criteria As String) As Boolean + + Dim Criteria1 As String + Dim Criteria2 As String + + If (RelationalOperator And SQL_Between) = False Then + TryBuildBetweenCriteria = False + Exit Function + End If + + If (RelationalOperator And SQL_Not) = SQL_Not Then 'Reverse condition + Criteria1 = BuildCriteria(FieldName, FieldDataType, SQL_LessThan, FilterValue, , IgnoreValue, False) + Criteria2 = BuildCriteria(FieldName, FieldDataType, SQL_GreaterThan, FilterValue2, , IgnoreValue, False) + Criteria = Criteria1 & SqlAndConcatString & Criteria2 + TryBuildBetweenCriteria = True + Exit Function + End If + + If FieldDataType = SQL_Numeric Then + If FilterValue2 Like "<=*" Then 'cut away + FilterValue2 = Mid(FilterValue2, 3) + ElseIf FilterValue2 Like "<*" Then + FilterValue2 = Mid(FilterValue2, 2) + Criteria1 = BuildCriteria(FieldName, FieldDataType, SQL_GreaterThan + SQL_Equal, FilterValue, , Null, False) + Criteria2 = BuildCriteria(FieldName, FieldDataType, SQL_LessThan, FilterValue2, , Null, False) + Criteria = Criteria1 & SqlAndConcatString & Criteria2 + TryBuildBetweenCriteria = True + Exit Function + End If + End If + + If IsNull(FilterValue2) Or IsMissing(FilterValue2) Or ValuesAreEqual(FieldDataType, FilterValue2, IgnoreValue) Then + RelationalOperator = SQL_GreaterThan + SQL_Equal + ElseIf IsNull(FilterValue) Or ValuesAreEqual(FieldDataType, FilterValue, IgnoreValue) Then + RelationalOperator = SQL_LessThan + SQL_Equal + FilterValue = FilterValue2 + FilterValue2 = GetCheckedIgnoreValue(IgnoreValue) + ElseIf (FieldDataType And SQL_Date) = SQL_Date And (RelationalOperator And SQL_Add_WildCardSuffix) Then + Criteria1 = BuildCriteria(FieldName, FieldDataType, SQL_GreaterThan + SQL_Equal, FilterValue, , Null, False) + Criteria2 = BuildCriteria(FieldName, FieldDataType, SQL_LessThan + SQL_Equal + SQL_Add_WildCardSuffix, FilterValue2, , Null, False) + Criteria = Criteria1 & SqlAndConcatString & Criteria2 + TryBuildBetweenCriteria = True + Exit Function + ElseIf (FieldDataType And SQL_Numeric) = SQL_Numeric And (RelationalOperator And SQL_Add_WildCardSuffix) Then + Criteria1 = BuildCriteria(FieldName, FieldDataType, SQL_GreaterThan + SQL_Equal, FilterValue, , Null, False) + Criteria2 = BuildCriteria(FieldName, FieldDataType, SQL_LessThan + SQL_Equal + SQL_Add_WildCardSuffix, FilterValue2, , Null, False) + Criteria = Criteria1 & SqlAndConcatString & Criteria2 + TryBuildBetweenCriteria = True + Exit Function + Else + Criteria = FieldName & " Between " & ConvertToSqlText(FilterValue, FieldDataType) & SqlAndConcatString & ConvertToSqlText(FilterValue2, FieldDataType) + TryBuildBetweenCriteria = True + Exit Function + End If + +End Function + +Private Function GetCheckedIgnoreValue(ByVal IgnoreValue As Variant) As Variant + If IsArray(IgnoreValue) Then + GetCheckedIgnoreValue = IgnoreValue(LBound(IgnoreValue)) + Else + GetCheckedIgnoreValue = IgnoreValue + End If +End Function + +Private Function NullFilterOrEmptyFilter(ByVal FieldName As String, ByVal FieldDataType As SqlFieldDataType, _ + ByVal RelationalOperator As SqlRelationalOperators, _ + ByVal Value As Variant, ByVal IgnoreValue As Variant, _ + ByRef NullFilterString As String, _ + Optional ByVal DisableIgnoreNullValue As Boolean = False) As Boolean + + If IsObject(IgnoreValue) Then + If IgnoreValue Is Nothing Then + If IsNull(Value) Then + If (RelationalOperator And SQL_Not) = SQL_Not Then + NullFilterString = FieldName & " Is Not Null" + Else + NullFilterString = FieldName & " Is Null" + End If + NullFilterOrEmptyFilter = True + Else + NullFilterOrEmptyFilter = False + End If + Exit Function + End If + End If + + If IsNull(Value) Then + If DisableIgnoreNullValue Then + NullFilterString = FieldName & " Is Null" + ElseIf Not ValuesAreEqual(FieldDataType, Value, IgnoreValue) Then + NullFilterString = FieldName & " Is Null" + End If + NullFilterOrEmptyFilter = True + ElseIf IsArray(Value) Then + Dim CheckArray() As Variant +On Error Resume Next + CheckArray = Value + If Err.Number = 0 Then + If (0 / 1) + (Not Not CheckArray) = 0 Then + NullFilterOrEmptyFilter = True + Exit Function + End If + Else + Err.Clear + Dim ArraySize As Long + ArraySize = UBound(Value) + If Err.Number <> 0 Then + Err.Clear + NullFilterOrEmptyFilter = True + Exit Function + End If + End If + Else + NullFilterOrEmptyFilter = ValuesAreEqual(FieldDataType, Value, IgnoreValue) + End If + + If (RelationalOperator And SQL_Not) = SQL_Not Then + NullFilterString = Replace(NullFilterString, "Is Null", "Is Not Null") + End If + +End Function + +Private Function ValuesAreEqual(ByVal FieldDataType As SqlFieldDataType, ByVal Value As Variant, ByVal Value2 As Variant) As Boolean + + If IsArray(Value2) Then + ValuesAreEqual = ArrayContains(FieldDataType, Value2, Value) + ElseIf IsNull(Value) Then + ValuesAreEqual = IsNull(Value2) + ElseIf IsNull(Value2) Then + ValuesAreEqual = False + Else + Select Case FieldDataType + Case SqlFieldDataType.SQL_Text + ValuesAreEqual = (VBA.StrComp(Value, Value2, vbTextCompare) = 0) + Case SqlFieldDataType.SQL_Numeric + ValuesAreEqual = (CDbl(Value) = CDbl(Value2)) + Case SqlFieldDataType.SQL_Date + ValuesAreEqual = (CDate(Value) = CDate(Value2)) + Case SqlFieldDataType.SQL_Boolean + ValuesAreEqual = (CBool(Value) = CBool(Value2)) + Case Else + ValuesAreEqual = (Value = Value2) + End Select + End If + +End Function + +Private Function ArrayContains(ByVal FieldDataType As SqlFieldDataType, ByVal ArrayToCheck As Variant, ByVal SearchValue As Variant) As Boolean + + Dim i As Long + + If IsNull(SearchValue) Then + ArrayContains = ArrayContainsNull(ArrayToCheck) + Exit Function + End If + + For i = LBound(ArrayToCheck) To UBound(ArrayToCheck) + If ValuesAreEqual(FieldDataType, ArrayToCheck(i), SearchValue) Then + ArrayContains = True + Exit Function + End If + Next + + ArrayContains = False + +End Function + +Private Function ArrayContainsNull(ByVal ArrayToCheck As Variant) As Boolean + + Dim i As Long + + For i = LBound(ArrayToCheck) To UBound(ArrayToCheck) + If IsNull(ArrayToCheck(i)) Then + ArrayContainsNull = True + Exit Function + End If + Next + + ArrayContainsNull = False + +End Function + +Private Function GetValueArrayString(ByVal Value As Variant, ByVal FieldDataType As SqlFieldDataType, _ + ByVal Delimiter As String, ByVal IgnoreValue As Variant) As String + + Dim i As Long + Dim s As String + + For i = LBound(Value) To UBound(Value) + If IsArray(IgnoreValue) Then + If ArrayContains(FieldDataType, IgnoreValue, Value(i)) Then + Else + s = s & Delimiter & ConvertToSqlText(Value(i), FieldDataType) + End If + Else + If Value(i) = IgnoreValue Then + ElseIf IsNull(Value(i)) And IsNull(IgnoreValue) Then + Else + s = s & Delimiter & ConvertToSqlText(Value(i), FieldDataType) + End If + End If + Next + If Len(s) > 0 And Len(Delimiter) > 0 Then + s = Mid(s, Len(Delimiter) + 1) + End If + GetValueArrayString = s + +End Function + +Private Function RemoveNullFromInValueString(ByRef ValueString As String) As Boolean + + Const NullCheckString As String = ",Null," + Dim TestString As String + + TestString = "," & ValueString & "," + + If Not (InStr(1, TestString, NullCheckString) > 0) Then + RemoveNullFromInValueString = False + Exit Function + End If + + TestString = Replace(TestString, NullCheckString, ",") + + If Len(TestString) > 1 Then + ValueString = Mid(TestString, 2, Len(TestString) - 2) + Else + ValueString = vbNullString + End If + + RemoveNullFromInValueString = True + +End Function diff --git a/source/modules/StringCollection.cls b/source/modules/StringCollection.cls new file mode 100644 index 0000000..34133ec --- /dev/null +++ b/source/modules/StringCollection.cls @@ -0,0 +1,318 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "StringCollection" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'--------------------------------------------------------------------------------------- +' Class: text.StringCollection +'--------------------------------------------------------------------------------------- +' +' Collection for strings +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + +'--------------------------------------------------------------------------------------- +' +' text/StringCollection.cls +' _codelib/license.bas +' _test/text/StringCollectionTests.cls +' +'--------------------------------------------------------------------------------------- +' +Option Compare Text +Option Explicit + +Private m_Items As Collection + +Private Sub Class_Initialize() + Set m_Items = New Collection +End Sub + +Private Sub Class_Terminate() + Set m_Items = Nothing +End Sub + +'--------------------------------------------------------------------------------------- +' Property: Self +'--------------------------------------------------------------------------------------- +' +' Reference to self (Me) +' +' Remarks: +' Useful for with-block +' +' Returns: +' Database.StringCollection +' +'--------------------------------------------------------------------------------------- +Public Property Get Self() As StringCollection + Set Self = Me +End Property + +'--------------------------------------------------------------------------------------- +' Property: Items +'--------------------------------------------------------------------------------------- +' +' Collection with items +' +' Returns: +' VBA.Collection +' +'--------------------------------------------------------------------------------------- +Public Property Get Items() As Collection + Set Items = m_Items +End Property + +'--------------------------------------------------------------------------------------- +' Property: Item +'--------------------------------------------------------------------------------------- +' +' Item of Collection +' +' Parameters: +' Index - (Variant) +' +' Returns: +' Item string - (String) +' +'--------------------------------------------------------------------------------------- +Public Property Get Item(ByVal Index As Variant) As String + Item = m_Items.Item(Index) +End Property + +Public Property Let Item(ByVal Index As Variant, ByVal NewValue As String) +Attribute Item.VB_UserMemId = 0 + m_Items.Add NewValue, , , Index + m_Items.Remove Index +End Property + +'--------------------------------------------------------------------------------------- +' Sub: Add +'--------------------------------------------------------------------------------------- +' +' Add string to collection +' +' Parameters: +' Item to add - (String) +' +'--------------------------------------------------------------------------------------- +Public Sub Add(ByVal Item As String) + m_Items.Add Item +End Sub + +'--------------------------------------------------------------------------------------- +' Sub: AddFromArray +'--------------------------------------------------------------------------------------- +' +' Add items form an array to collection +' +' Parameters: +' ArrayToAdd - (Variant) +' ItemStringFormat - (String) Format each item of Array with ItemStringFormat before add to collection +' +'--------------------------------------------------------------------------------------- +Public Sub AddFromArray(ByRef ArrayToAdd As Variant, Optional ByVal ItemStringFormat As String = vbNullString) + + Dim i As Long + + For i = LBound(ArrayToAdd) To UBound(ArrayToAdd) + m_Items.Add Format(ArrayToAdd(i), ItemStringFormat) + Next + +End Sub + +'--------------------------------------------------------------------------------------- +' Sub: AddFromCollection +'--------------------------------------------------------------------------------------- +' +' Add items form a collection to string collection +' +' Parameters: +' CollectionToAppend - (Object) .. so that all collections with Enumarable and Item(index) interface can be run through +' ItemStringFormat - (String) Format each item of collection with ItemStringFormat before add to collection +' +'--------------------------------------------------------------------------------------- +Public Sub AddFromCollection(ByVal CollectionToAppend As Object, Optional ByVal ItemStringFormat As String = vbNullString) + + Dim itm As Variant + + For Each itm In CollectionToAppend + m_Items.Add Format(itm, ItemStringFormat) + Next + +End Sub + +'--------------------------------------------------------------------------------------- +' Function: ToString +'--------------------------------------------------------------------------------------- +' +' Return Collection items as joined String +' +' Parameters: +' Delimiter - (String) Example: ", " => "Item1, Item2, Item3" +' ItemPrefix - (String) Prefix for each item +' ItemSuffix - (String) Suffix for each item +' IgnoreEmptyValue - (Boolean) don't output an empty item +' IgnoreDuplicateValues - (Boolean) True = don't output duplicate items +' +' Returns: +' String +' +'--------------------------------------------------------------------------------------- +Public Function ToString(Optional ByVal Delimiter As String = ", ", _ + Optional ByVal ItemPrefix As String = vbNullString, _ + Optional ByVal ItemSuffix As String = vbNullString, _ + Optional ByVal IgnoreEmptyValue As Boolean = False, _ + Optional ByVal IgnoreDuplicateValues As Boolean = False) As String + + Dim s As String + + s = VBA.Join(ToStringArray(IgnoreEmptyValue, IgnoreDuplicateValues), ItemSuffix & Delimiter & ItemPrefix) + If Len(s) > 0 Then s = ItemPrefix & s & ItemSuffix + + ToString = s + +End Function + +'--------------------------------------------------------------------------------------- +' Function: ToStringArray +'--------------------------------------------------------------------------------------- +' +' Return Collection items as String array +' +' Parameters: +' IgnoreEmptyValue - (Boolean) don't output an empty item +' IgnoreDuplicateValues - (Boolean) True = don't output duplicate items +' +' Returns: +' String array +' +'--------------------------------------------------------------------------------------- +Public Function ToStringArray(Optional ByVal IgnoreEmptyValue As Boolean = False, _ + Optional ByVal IgnoreDuplicateValues As Boolean = False) As String() + + Dim ItemArray() As String + Dim MaxArrayIndex As Long + Dim i As Long + + MaxArrayIndex = m_Items.Count - 1 + + If MaxArrayIndex < 0 Then + ToStringArray = ItemArray + Exit Function + End If + + If IgnoreEmptyValue Then + If IgnoreDuplicateValues Then + ToStringArray = RemoveDuplicateValues(GetArrayWithoutEmptyValues()) + Else + ToStringArray = GetArrayWithoutEmptyValues() + End If + Exit Function + End If + + ReDim ItemArray(0 To MaxArrayIndex) + For i = 0 To MaxArrayIndex + ItemArray(i) = m_Items.Item(i + 1) + Next + + If IgnoreDuplicateValues Then + ToStringArray = RemoveDuplicateValues(ItemArray) + Else + ToStringArray = ItemArray + End If + +End Function + +Private Function GetArrayWithoutEmptyValues() As String() + + Dim ItemArray() As String + Dim MaxArrayIndex As Long + Dim ItemIndex As Long + Dim itm As Variant + + MaxArrayIndex = m_Items.Count - 1 + + If MaxArrayIndex < 0 Then + GetArrayWithoutEmptyValues = ItemArray + Exit Function + End If + + ReDim ItemArray(0 To MaxArrayIndex) + ItemIndex = -1 + For Each itm In m_Items + If Len(itm) > 0 Then + ItemIndex = ItemIndex + 1 + ItemArray(ItemIndex) = itm + End If + Next + + If ItemIndex = -1 Then + Erase ItemArray + GetArrayWithoutEmptyValues = ItemArray + Exit Function + End If + + If ItemIndex < (m_Items.Count - 1) Then + ReDim Preserve ItemArray(0 To ItemIndex) + End If + + GetArrayWithoutEmptyValues = ItemArray + +End Function + +Private Function RemoveDuplicateValues(ByRef ArrayToCheck() As String) As String() + + Dim ItemArray() As String + Dim MaxArrayIndex As Long + Dim ItemIndex As Long + Dim ArrayItem As Variant + + MaxArrayIndex = UBound(ArrayToCheck) + + If MaxArrayIndex = 0 Then + RemoveDuplicateValues = ArrayToCheck + Exit Function + End If + + ReDim ItemArray(MaxArrayIndex) + + ItemIndex = -1 + For Each ArrayItem In ArrayToCheck + If Not ValueExistsInArray(ItemArray, ArrayItem, ItemIndex) Then + ItemIndex = ItemIndex + 1 + ItemArray(ItemIndex) = ArrayItem + End If + Next + + If ItemIndex < (m_Items.Count - 1) Then + ReDim Preserve ItemArray(0 To ItemIndex) + End If + + RemoveDuplicateValues = ItemArray + +End Function + +Private Function ValueExistsInArray(ByRef ArrayToCheck() As String, ByVal ValueToCheck As String, ByVal CheckUntilArrayIndex As Long) As Boolean + + Dim i As Long + + If CheckUntilArrayIndex < 0 Then + Exit Function + End If + + For i = LBound(ArrayToCheck) To CheckUntilArrayIndex + If StrComp(ArrayToCheck(i), ValueToCheck, vbBinaryCompare) = 0 Then + ValueExistsInArray = True + Exit Function + End If + Next + +End Function diff --git a/source/modules/_AddInAPI.bas b/source/modules/_AddInAPI.bas index e03605b..12c3856 100644 --- a/source/modules/_AddInAPI.bas +++ b/source/modules/_AddInAPI.bas @@ -2,6 +2,17 @@ Option Compare Database Option Explicit +'--------------------------------------------------------------------------------------- +' Function: StartAddIn +'--------------------------------------------------------------------------------------- +' +' Default start of add-in ... open add-in form +' +'--------------------------------------------------------------------------------------- +Public Function StartAddIn() + StartApplication +End Function + '--------------------------------------------------------------------------------------- ' Function: API diff --git a/source/modules/_config_Application.bas b/source/modules/_config_Application.bas new file mode 100644 index 0000000..5a3c570 --- /dev/null +++ b/source/modules/_config_Application.bas @@ -0,0 +1,96 @@ +Attribute VB_Name = "_config_Application" +'--------------------------------------------------------------------------------------- +' Modul: _config_Application +'--------------------------------------------------------------------------------------- +'--------------------------------------------------------------------------------------- +' +' _codelib/license.bas +' %AppFolder%/source/defGlobal_AccUnitLoader.bas +' base/modApplication.basbase/ApplicationHandler.cls +' base/modErrorHandler.bas +' _codelib/addins/shared/AccUnitConfiguration.cls +' +'--------------------------------------------------------------------------------------- +' +Option Compare Text +Option Explicit +Option Private Module + +'Version number +Private Const APPLICATION_VERSION As String = "0.4.2.250426" + +Private Const APPLICATION_NAME As String = "ACLib Declaration Dictionary" +Private Const APPLICATION_FULLNAME As String = "Access-CodeLib - Declaration Dictionary" +Private Const APPLICATION_TITLE As String = APPLICATION_NAME + +Private Const APPLICATION_STARTFORMNAME As String = "DeclarationDictForm" + +Private m_Extensions As Object 'ApplicationHandler_ExtensionCollection + +Public Const DefaultDeclDictTableName As String = "USysDeclDict" + +'--------------------------------------------------------------------------------------- +' Sub: InitConfig +'--------------------------------------------------------------------------------------- +'/** +' +' Konfigurationseinstellungen initialisieren +' +' Möglichkeit einer Referenzübergabe, damit nicht CurrentApplication genutzt werden muss +' +' +' +'**/ +'--------------------------------------------------------------------------------------- +Public Sub InitConfig(Optional ByRef CurrentAppHandlerRef As Object = Nothing) + +'---------------------------------------------------------------------------- +' Anwendungsinstanz einstellen +' + If CurrentAppHandlerRef Is Nothing Then + Set CurrentAppHandlerRef = modApplication.CurrentApplication + End If + + With CurrentAppHandlerRef + + 'Zur Sicherheit AccDb einstellen + Set .AppDb = Application.CodeDb 'muss auf CodeDb zeigen, + 'da diese Anwendung als Add-In verwendet wird + + 'Anwendungsname + .ApplicationName = APPLICATION_NAME + .ApplicationFullName = APPLICATION_FULLNAME + .ApplicationTitle = APPLICATION_TITLE + + 'Version + .Version = APPLICATION_VERSION + + ' Formular, das am Ende von CurrentApplication.Start aufgerufen wird + .ApplicationStartFormName = APPLICATION_STARTFORMNAME + + End With + +End Sub + + +'############################################################################ +' +' Funktionen für die Anwendungswartung +' (werden nur im Anwendungsentwurf benötigt) +' +'---------------------------------------------------------------------------- +' Hilfsfunktion zum Speichern von Dateien in die lokale AppFile-Tabelle +'---------------------------------------------------------------------------- +'Private Sub SetAppFiles() +' +' Dim accFileName As Variant +' +' ' Call CurrentApplication.Extensions("AppFile").SaveAppFile("AppIcon", CodeProject.Path & "\" & APPLICATION_ICONFILE) +' With modApplication.CurrentApplication.Extensions("AppFile") +' For Each accFileName In AccUnitLoaderConfigProcedures.AccUnitFileNames +' .SaveAppFile accFileName, CodeProject.Path & "\lib\" & accFileName, True +' Next +' End With +' +'End Sub diff --git a/source/modules/_initApplication.bas b/source/modules/_initApplication.bas new file mode 100644 index 0000000..72dd547 --- /dev/null +++ b/source/modules/_initApplication.bas @@ -0,0 +1,63 @@ +Attribute VB_Name = "_initApplication" +'--------------------------------------------------------------------------------------- +' Package: base._initApplication +'--------------------------------------------------------------------------------------- +' +' Initialising the application +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + +'--------------------------------------------------------------------------------------- +' +' base/_initApplication.bas +' _codelib/license.bas +' base/modApplication.bas +' +'--------------------------------------------------------------------------------------- +' +Option Compare Text +Option Explicit +Option Private Module + +'------------------------- +' Anwendungseinstellungen +'------------------------- +' +' => see _config_Application +' +'------------------------- + +'--------------------------------------------------------------------------------------- +' Function: StartApplication +'--------------------------------------------------------------------------------------- +' +' Procedure for application start-up +' +' Returns: +' Boolean - sucess = true +' +'--------------------------------------------------------------------------------------- +Public Function StartApplication() As Boolean + +On Error GoTo HandleErr + + StartApplication = CurrentApplication.Start + +ExitHere: + Exit Function + +HandleErr: + StartApplication = False + MsgBox "Application can not be started.", vbCritical, CurrentApplicationName + Application.Quit acQuitSaveNone + Resume ExitHere + +End Function + +Public Sub RestoreApplicationDefaultSettings() + On Error Resume Next + CurrentApplication.ApplicationTitle = CurrentApplication.ApplicationFullName +End Sub diff --git a/source/modules/modApplication.bas b/source/modules/modApplication.bas new file mode 100644 index 0000000..1cb71d9 --- /dev/null +++ b/source/modules/modApplication.bas @@ -0,0 +1,145 @@ +Attribute VB_Name = "modApplication" +Attribute VB_Description = "Standard-Prozeduren für die Arbeit mit ApplicationHandler" +'--------------------------------------------------------------------------------------- +' Package: base.modApplication +'--------------------------------------------------------------------------------------- +' +' Standard procedures for working with ApplicationHandler +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + +'--------------------------------------------------------------------------------------- +' +' base/modApplication.bas +' _codelib/license.bas +' base/ApplicationHandler.cls +' base/_config_Application.bas +' +'--------------------------------------------------------------------------------------- +' +Option Compare Text +Option Explicit +Option Private Module + +' Instance of the main control +Private m_ApplicationHandler As ApplicationHandler +Private m_ApplicationName As String ' Cache for application names + ' if CurrentApplication.ApplicationName is not running + +'--------------------------------------------------------------------------------------- +' Property: CurrentApplication +'--------------------------------------------------------------------------------------- +' +' Property for ApplicationHandler instance (use this property in code) +' +'--------------------------------------------------------------------------------------- +Public Property Get CurrentApplication() As ApplicationHandler + If m_ApplicationHandler Is Nothing Then + InitApplication + End If + Set CurrentApplication = m_ApplicationHandler +End Property + +'--------------------------------------------------------------------------------------- +' Property: CurrentApplicationName +'--------------------------------------------------------------------------------------- +' +' Name of the current application +' +' Remarks: +' Uses CurrentApplication.ApplicationName +' +'--------------------------------------------------------------------------------------- +Public Property Get CurrentApplicationName() As String +' incl. emergency error handler if CurrentApplication is not instantiated + +On Error GoTo HandleErr + + CurrentApplicationName = CurrentApplication.ApplicationName + +ExitHere: + Exit Property + +HandleErr: + CurrentApplicationName = GetApplicationNameFromDb + Resume ExitHere + +End Property + +Private Function GetApplicationNameFromDb() As String + + If Len(m_ApplicationName) = 0 Then +On Error Resume Next +'1. Value from title property + m_ApplicationName = CodeDb.Properties("AppTitle").Value + If Len(m_ApplicationName) = 0 Then +'2. Value from file name + m_ApplicationName = CodeDb.Name + m_ApplicationName = Left$(m_ApplicationName, InStrRev(m_ApplicationName, ".") - 1) + End If + End If + + GetApplicationNameFromDb = m_ApplicationName + +End Function + +'--------------------------------------------------------------------------------------- +' Sub: TraceLog +'--------------------------------------------------------------------------------------- +' +' TraceLog +' +' Parameters: +' Msg - Message text +' Args - (ParamArray) +' +'--------------------------------------------------------------------------------------- +Public Sub TraceLog(ByRef Msg As String, ParamArray Args() As Variant) + CurrentApplication.WriteLog Msg, ApplicationHandlerLogType.AppLogType_Tracing, Args +End Sub + +Private Sub InitApplication() + + Set m_ApplicationHandler = New ApplicationHandler + Call InitConfig(m_ApplicationHandler) + +End Sub + + +'--------------------------------------------------------------------------------------- +' Sub: DisposeCurrentApplicationHandler +'--------------------------------------------------------------------------------------- +' +' Destroy instance of ApplicationHandler and the extensions +' +'--------------------------------------------------------------------------------------- +Public Sub DisposeCurrentApplicationHandler() + + Dim CheckCnt As Long, MaxCnt As Long + +On Error Resume Next + + If Not m_ApplicationHandler Is Nothing Then + m_ApplicationHandler.Dispose + End If + + Set m_ApplicationHandler = Nothing + +End Sub + + +'--------------------------------------------------------------------------------------- +' +' Auxiliary procedures +Public Sub WriteApplicationLogEntry(ByVal Msg As String, _ + Optional LogType As ApplicationHandlerLogType, _ + Optional ByVal Args As Variant) + CurrentApplication.WriteLog Msg, LogType, Args +End Sub + +Public Property Get PublicPath() As String + PublicPath = CurrentApplication.PublicPath +End Property diff --git a/source/modules/modErrorHandler.bas b/source/modules/modErrorHandler.bas new file mode 100644 index 0000000..4dc7d04 --- /dev/null +++ b/source/modules/modErrorHandler.bas @@ -0,0 +1,316 @@ +Attribute VB_Name = "modErrorHandler" +Attribute VB_Description = "Prozeduren für die Fehlerbehandlung" +'--------------------------------------------------------------------------------------- +' Package: base.modErrorHandler +'--------------------------------------------------------------------------------------- +' +' Error handling procedures +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + +'--------------------------------------------------------------------------------------- +' +' base/modErrorHandler.bas +' _codelib/license.bas +' +'--------------------------------------------------------------------------------------- +' +Option Compare Text +Option Explicit +Option Private Module + +'--------------------------------------------------------------------------------------- +' Enum: ACLibErrorHandlerMode +'--------------------------------------------------------------------------------------- +' +' ErrorHandler Modes (error handling variants) +' +' aclibErrRaise - (0) Pass error to application +' aclibErrMsgBox - (1) Show error in MsgBox +' aclibErrIgnore - (2) Ignore error, do not display any message +' aclibErrFile - (4) Write error information to file +' +' Remarks: +' The values {0,1,2} exclude each other. The value 4 (aclibErrFile) can be added arbitrarily to {0,1,2}. +' Example: Init aclibErrRaise + aclibErrFile +' +Public Enum ACLibErrorHandlerMode + [_aclibErr_default] = -1 + aclibErrRaise = 0& 'Pass error to application + aclibErrMsgBox = 1& 'MsgBox + aclibErrIgnore = 2& 'ignore error, do not display any message + aclibErrFile = 4& 'Output to file +End Enum + +'--------------------------------------------------------------------------------------- +' Enum: ACLibErrorResumeMode +'--------------------------------------------------------------------------------------- +' +' Processing parameters in case of errors +' +' aclibErrExit - (0) Termination (function exit) +' aclibErrResume - (1) Resume, Problem fixed externally +' aclibErrResumeNext - (2) Resume next, continue working in the code at the next point +' +' Remarks: +' Used for error events +' +Public Enum ACLibErrorResumeMode + aclibErrExit = 0 'Termination (function exit) + aclibErrResume = 1 'Resume, Problem fixed externally + aclibErrResumeNext = 2 'Resume next, continue working in the code at the next point +End Enum + +'--------------------------------------------------------------------------------------- +' Enum: ACLibErrorNumbers +'--------------------------------------------------------------------------------------- +Public Enum ACLibErrorNumbers + ERRNR_NOOBJECT = vbObjectError + 1001 + ERRNR_NOCONFIG = vbObjectError + 1002 + ERRNR_INACTIVE = vbObjectError + 1003 + ERRNR_FORBIDDEN = vbObjectError + 9001 +End Enum + +'Default settings: +Private Const DEFAULT_ERRORHANDLERMODE As Long = ACLibErrorHandlerMode.[_aclibErr_default] +Private Const DEFAULT_ERRORRESUMEMODE As Long = ACLibErrorResumeMode.aclibErrExit + +Private Const ERRORSOURCE_DELIMITERSYMBOL As String = "->" + +'Auxiliary variables +Private m_DefaultErrorHandlerMode As Long +Private m_ErrorHandlerLogFile As String + +'--------------------------------------------------------------------------------------- +' Property: DefaultErrorHandlerMode +'--------------------------------------------------------------------------------------- +' +' Default behaviour of error handling +' +'--------------------------------------------------------------------------------------- +Public Property Get DefaultErrorHandlerMode() As ACLibErrorHandlerMode +On Error Resume Next + DefaultErrorHandlerMode = m_DefaultErrorHandlerMode +End Property + +Public Property Let DefaultErrorHandlerMode(ByVal ErrMode As ACLibErrorHandlerMode) + m_DefaultErrorHandlerMode = ErrMode +End Property + +'--------------------------------------------------------------------------------------- +' Property: ErrorHandlerLogFile +'--------------------------------------------------------------------------------------- +' +' Log file for error message +' +'--------------------------------------------------------------------------------------- +Public Property Get ErrorHandlerLogFile() As String + ErrorHandlerLogFile = m_ErrorHandlerLogFile +End Property + +Public Property Let ErrorHandlerLogFile(ByVal Path As String) +'/** +' * @todo: Checking for the existence of the file or at least the directory +'**/ + m_ErrorHandlerLogFile = Path +End Property + +'--------------------------------------------------------------------------------------- +' Function: HandleError +'--------------------------------------------------------------------------------------- +' +' Standard procedure for error handling +' +' Parameters: +' ErrNumber"> +' ErrSource"> +' ErrDescription"> +' ErrHandlerMode"> +' +' Returns: +' ACLibErrorResumeMode +' +' Remarks: +'Example: +' +'Private Sub ExampleProc() +' +'On Error GoTo HandleErr +' +'[...] +' +'ExitHere: +'On Error Resume Next +' Exit Sub +' +'HandleErr: +' Select Case HandleError(Err.Number, "ExampleProc", Err.Description) +' Case ACLibErrorResumeMode.aclibErrResume +' Resume +' Case ACLibErrorResumeMode.aclibErrResumeNext +' Resume Next +' Case Else +' Resume ExitHere +' End Select +' +'End Sub +' +' +'--------------------------------------------------------------------------------------- +Public Function HandleError(ByVal ErrNumber As Long, ByVal ErrSource As String, _ + Optional ByVal ErrDescription As String, _ + Optional ByVal ErrHandlerMode As ACLibErrorHandlerMode = DEFAULT_ERRORHANDLERMODE _ + ) As ACLibErrorResumeMode +'Here it would also be possible to activate another ErrorHandler (e.g. ErrorHandler class). + + If ErrHandlerMode = ACLibErrorHandlerMode.[_aclibErr_default] Then + ErrHandlerMode = m_DefaultErrorHandlerMode + End If + + HandleError = ProcHandleError(ErrNumber, ErrSource, ErrDescription, ErrHandlerMode) + +End Function + +Private Function ProcHandleError(ByRef ErrNumber As Long, ByRef ErrSource As String, _ + ByRef ErrDescription As String, _ + ByVal ErrHandlerMode As ACLibErrorHandlerMode _ + ) As ACLibErrorResumeMode + + Dim NewErrSource As String + Dim NewErrDescription As String + Dim CurrentErrSource As String + + NewErrDescription = Err.Description + CurrentErrSource = Err.Source + +On Error Resume Next + + NewErrSource = ErrSource + If Len(NewErrSource) = 0 Then + NewErrSource = CurrentErrSource + ElseIf CurrentErrSource <> GetApplicationVbProjectName Then + NewErrSource = NewErrSource & ERRORSOURCE_DELIMITERSYMBOL & CurrentErrSource + End If + + If Len(ErrDescription) > 0 Then + NewErrDescription = ErrDescription + End If + + 'Output to file + If (ErrHandlerMode And ACLibErrorHandlerMode.aclibErrFile) = ACLibErrorHandlerMode.aclibErrFile Then + PrintToFile ErrNumber, NewErrSource, NewErrDescription + ErrHandlerMode = ErrHandlerMode - ACLibErrorHandlerMode.aclibErrFile + End If + + 'Show Messagebox + If (ErrHandlerMode And ACLibErrorHandlerMode.aclibErrMsgBox) = ACLibErrorHandlerMode.aclibErrMsgBox Then + ShowErrorMessage ErrNumber, NewErrSource, NewErrDescription + ErrHandlerMode = ErrHandlerMode - ACLibErrorHandlerMode.aclibErrMsgBox + End If + +'Error handler + Err.Clear +On Error GoTo 0 + Select Case ErrHandlerMode + Case ACLibErrorHandlerMode.aclibErrRaise ' Passing to the application + Err.Raise ErrNumber, NewErrSource, NewErrDescription + Case ACLibErrorHandlerMode.aclibErrMsgBox ' show Msgbox + + Case ACLibErrorHandlerMode.aclibErrIgnore 'Skip error + ' + Case Else '(should never actually occur) ... pass on to application + Err.Raise ErrNumber, NewErrSource, NewErrDescription + End Select + + 'return resume mode + ProcHandleError = DEFAULT_ERRORRESUMEMODE ' This will help when using a class + +End Function + +Public Sub ShowErrorMessage(ByVal ErrNumber As Long, ByRef ErrSource As String, ByRef ErrDescription As String) + + Dim ErrMsgBoxTitle As String + Dim Pos As Long + Dim TempString As String + +On Error Resume Next + + Const LineBreakPos As Long = 50 + + Pos = InStr(1, ErrSource, ERRORSOURCE_DELIMITERSYMBOL, vbBinaryCompare) + If Pos > 1 Then + ErrMsgBoxTitle = Left$(ErrSource, Pos - 1) + Else + ErrMsgBoxTitle = ErrSource + End If + + If Len(ErrSource) > LineBreakPos Then + Pos = InStr(LineBreakPos, ErrSource, ERRORSOURCE_DELIMITERSYMBOL) + If Pos > 0 Then + Do While Pos > 0 + TempString = TempString & Left$(ErrSource, Pos - 1) & vbNewLine + ErrSource = Mid$(ErrSource, Pos) + Pos = InStr(LineBreakPos, ErrSource, ERRORSOURCE_DELIMITERSYMBOL) + Loop + ErrSource = TempString & ErrSource + End If + End If + + VBA.MsgBox "Error " & ErrNumber & ": " & vbNewLine & ErrDescription & vbNewLine & vbNewLine & "(" & ErrSource & ")", _ + vbCritical + vbSystemModal + vbMsgBoxSetForeground, ErrMsgBoxTitle + +End Sub + +Private Sub PrintToFile(ByRef ErrNumber As Long, ByRef ErrSource As String, _ + ByRef ErrDescription As String) + + Dim FileSource As String + Dim f As Long + Dim WriteToFile As Boolean + Dim PathToErrLogFile As String + +On Error Resume Next + + WriteToFile = True + + FileSource = "[" & ErrSource & "]" + PathToErrLogFile = ErrorHandlerLogFile + If Len(PathToErrLogFile) = 0 Then + PathToErrLogFile = CurrentProject.Path & "\Error.log" + End If + f = FreeFile + Open PathToErrLogFile For Append As #f + Print #f, Format$(Now(), _ + "yyyy-mm-tt hh:nn:ss "); FileSource; _ + " Error "; CStr(ErrNumber); ": "; ErrDescription + Close #f + +End Sub + +Private Function GetApplicationVbProjectName() As String + + Static VbProjectName As String + + Dim DbFile As String + Dim vbp As Object + +On Error Resume Next + + If Len(VbProjectName) = 0 Then + VbProjectName = Access.VBE.ActiveVBProject.Name + DbFile = CurrentDb.Name + 'Do not use UNCPath => Code module has no dependencies + If Access.VBE.ActiveVBProject.FileName <> DbFile Then + For Each vbp In Access.VBE.VBProjects + If vbp.FileName = DbFile Then + VbProjectName = vbp.Name + End If + Next + End If + End If + GetApplicationVbProjectName = VbProjectName + +End Function diff --git a/source/tables/USysRegInfo.txt b/source/tables/USysRegInfo.txt new file mode 100644 index 0000000..fa2f274 --- /dev/null +++ b/source/tables/USysRegInfo.txt @@ -0,0 +1,4 @@ +Subkey Type ValName Value +HKEY_CURRENT_ACCESS_PROFILE\\Menu Add-Ins\\ACLib Declaration Dictionary 0 +HKEY_CURRENT_ACCESS_PROFILE\\Menu Add-Ins\\ACLib Declaration Dictionary 1 Expression =StartAddIn() +HKEY_CURRENT_ACCESS_PROFILE\\Menu Add-Ins\\ACLib Declaration Dictionary 1 Library |ACCDIR\\ACLibDeclarationDict.accda diff --git a/source/tbldefs/USysRegInfo.sql b/source/tbldefs/USysRegInfo.sql new file mode 100644 index 0000000..35e1b05 --- /dev/null +++ b/source/tbldefs/USysRegInfo.sql @@ -0,0 +1,6 @@ +CREATE TABLE [USysRegInfo] ( + [Subkey] VARCHAR (255), + [Type] LONG, + [ValName] VARCHAR (255), + [Value] VARCHAR (255) +) diff --git a/source/tbldefs/USysRegInfo.xml b/source/tbldefs/USysRegInfo.xml new file mode 100644 index 0000000..7c81a95 --- /dev/null +++ b/source/tbldefs/USysRegInfo.xml @@ -0,0 +1,65 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/source/tbldefs/tabWords.sql b/source/tbldefs/tabWords.sql new file mode 100644 index 0000000..dc08402 --- /dev/null +++ b/source/tbldefs/tabWords.sql @@ -0,0 +1,5 @@ +CREATE TABLE [tabWords] ( + [Word] VARCHAR (255) CONSTRAINT [PrimaryKey] PRIMARY KEY UNIQUE NOT NULL, + [Variations] VARCHAR (255), + [Diff] BIT +) diff --git a/source/tbldefs/tabWords.xml b/source/tbldefs/tabWords.xml new file mode 100644 index 0000000..505613f --- /dev/null +++ b/source/tbldefs/tabWords.xml @@ -0,0 +1,104 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/source/vbe-project.json b/source/vbe-project.json index acd84bc..dba0b4e 100644 --- a/source/vbe-project.json +++ b/source/vbe-project.json @@ -4,9 +4,9 @@ "Description": "VBE Project" }, "Items": { - "Name": "ACLibDeclarationDictCore", + "Name": "ACLibDeclarationDict", "Description": "", - "FileName": "ACLibDeclarationDictCore.accda", + "FileName": "ACLibDeclarationDict.accda", "HelpFile": "", "HelpContextId": 0, "ConditionalCompilationArguments": "", From 49d83e2f90f7b377da0296ec68f6a4779e716792 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= <115746022+josef-poetzl@users.noreply.github.com> Date: Sun, 27 Apr 2025 01:01:18 +0200 Subject: [PATCH 06/13] clean up (remove Module1.bas) --- source/modules/Module1.bas | 18 ------------------ 1 file changed, 18 deletions(-) delete mode 100644 source/modules/Module1.bas diff --git a/source/modules/Module1.bas b/source/modules/Module1.bas deleted file mode 100644 index 65f8b1b..0000000 --- a/source/modules/Module1.bas +++ /dev/null @@ -1,18 +0,0 @@ -Attribute VB_Name = "Module1" -Option Compare Database -Option Explicit - -Private Sub testn() - - Dim props As Object - Dim prop As Object - - Set props = CurrentProject.Properties - For Each prop In props - If prop.Name = "VCS Build Path" Then - props.Remove prop.Name - End If - - Next - -End Sub From 1a1a61155d28c62ec8665d47fc8b38e4bbfdc599 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= <115746022+josef-poetzl@users.noreply.github.com> Date: Sun, 27 Apr 2025 00:50:58 +0200 Subject: [PATCH 07/13] Update README.md --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index e5478a6..d1decf7 100644 --- a/README.md +++ b/README.md @@ -4,12 +4,12 @@ This Add-In lists all VBA declarations (variables, function names, constants, et The idea was born from a discussion ([msaccess-vcs-add-in: issue 599](https://github.com/joyfullservice/msaccess-vcs-addin/issues/599)) about the behavior of the VBA editor, which adapts each existing declaration to the last written capitalization of the same word. This leads to many unnecessary changes in commits when using a version control system. - ![ACLibDeclarationDictionary](https://github.com/user-attachments/assets/0ef05ef7-72aa-4786-a790-74e679df7f24) # ACLibDeclarationDictionaryCore -This Add-In lists all VBA declarations (variables, function names, constants, etc.) and ensures consistent letter case - Core components + +Core components: https://github.com/AccessCodeLib/ACLibDeclarationDictionaryCore ## API From 3a2e023283f996e82dd03b713fab0bb91a9d794e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= <115746022+josef-poetzl@users.noreply.github.com> Date: Fri, 30 May 2025 22:52:00 +0200 Subject: [PATCH 08/13] Create build-for-release.yml --- .github/workflows/build-for-release.yml | 83 +++++++++++++++++++++++++ 1 file changed, 83 insertions(+) create mode 100644 .github/workflows/build-for-release.yml diff --git a/.github/workflows/build-for-release.yml b/.github/workflows/build-for-release.yml new file mode 100644 index 0000000..57d7bd1 --- /dev/null +++ b/.github/workflows/build-for-release.yml @@ -0,0 +1,83 @@ +name: Build-self-hosted (on release) + +on: + release: + types: [published] + +permissions: + contents: write + id-token: write + attestations: write + +jobs: + build: + runs-on: [self-hosted, Windows, Office] + + steps: + - name: "Checkout code for release tag" + uses: actions/checkout@v4 + with: + ref: ${{ github.event.release.tag_name }} + + - name: "Build Access file (accdb/accde)" + id: build_access_file + uses: AccessCodeLib/msaccess-vcs-build@main + with: + source-dir: "./source" + target-dir: "bin" + vcs-url: "https://api.github.com/repos/josef-poetzl/msaccess-vcs-addin/releases/tags/v4.1.2-build" + timeout-minutes: 10 + + - name: "Create versioned ZIP file" + run: | + $zipName = "ACLibDeclarationDict_${{ github.event.release.tag_name }}.zip" + Compress-Archive -Path .\bin\* -DestinationPath $zipName + echo "ZIP_NAME=$zipName" | Out-File -FilePath $env:GITHUB_ENV -Append + + - name: "Upload ZIP to GitHub Release" + uses: softprops/action-gh-release@v1 + with: + files: ${{ env.ZIP_NAME }} + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + + - name: "Calculate SHA256 of ZIP" + id: hash + shell: pwsh + run: | + $zipName = "${{ env.ZIP_NAME }}" + $hash = Get-FileHash -Algorithm SHA256 -Path $zipName + $digest = "sha256:$($hash.Hash.ToLower())" + echo "ZIP_DIGEST=$digest" | Out-File -FilePath $env:GITHUB_ENV -Append + echo "digest=$digest" >> $env:GITHUB_OUTPUT + + - name: "Attestation" + uses: actions/attest-build-provenance@v2 + id: attestation + with: + subject-name: "${{ env.ZIP_NAME }}" + subject-digest: "${{ steps.hash.outputs.digest }}" + + - name: "Update release description with attestation URL" + shell: pwsh + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + REPO: ${{ github.repository }} + TAG: ${{ github.event.release.tag_name }} + run: | + $ErrorActionPreference = "Stop" + + # Alte Release Notes abrufen + $oldBody = gh release view $env:TAG --repo $env:REPO --json body --template "{{.body}}" + + # Attestation-URL zusammenbauen + $attestationId = "${{ steps.attestation.outputs.attestation-id }}" + $attestationUrl = "https://github.com/$($env:REPO)/attestations/$attestationId" + + # Neue Release Notes mit Attestation-Link + $newBody = "$oldBody`n`nAttestation: $attestationUrl" + + # Aktualisieren der Release Notes + gh release edit $env:TAG --repo $env:REPO --notes "$newBody" + + From f247f0874d44314cd5d8311bd152b6fa44f03a40 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Fri, 20 Jun 2025 23:24:44 +0200 Subject: [PATCH 09/13] upd. gitignore (zip) --- .gitignore | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 10ca69c..3b40124 100644 --- a/.gitignore +++ b/.gitignore @@ -27,4 +27,4 @@ vcs-index.json *.zip # don't commit dict files in this repository -*.accd[ab].DeclarationDict.txt \ No newline at end of file +*.accd[ab].DeclarationDict.txt From 0d7439ba1b467d6ec16a3cf30942bc43dd1e9ccb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Fri, 20 Jun 2025 23:44:55 +0200 Subject: [PATCH 10/13] adapt: core => add-in file --- .github/workflows/build-for-release.yml | 83 ------------------- .github/workflows/build-release-zip-file.yml | 13 +-- .../modules/_LoadAddIn.bas | 2 +- .../modules/_LoadAddIn.bas | 2 +- .../DeclarationDictTestCodemodule.cls | 0 .../DeclarationDictTests.cls | 0 .../ITestInterface.cls | 0 7 files changed, 4 insertions(+), 96 deletions(-) delete mode 100644 .github/workflows/build-for-release.yml rename Tests/{ACLibDeclarationDictCore => ACLibDeclarationDict}/DeclarationDictTestCodemodule.cls (100%) rename Tests/{ACLibDeclarationDictCore => ACLibDeclarationDict}/DeclarationDictTests.cls (100%) rename Tests/{ACLibDeclarationDictCore => ACLibDeclarationDict}/ITestInterface.cls (100%) diff --git a/.github/workflows/build-for-release.yml b/.github/workflows/build-for-release.yml deleted file mode 100644 index 57d7bd1..0000000 --- a/.github/workflows/build-for-release.yml +++ /dev/null @@ -1,83 +0,0 @@ -name: Build-self-hosted (on release) - -on: - release: - types: [published] - -permissions: - contents: write - id-token: write - attestations: write - -jobs: - build: - runs-on: [self-hosted, Windows, Office] - - steps: - - name: "Checkout code for release tag" - uses: actions/checkout@v4 - with: - ref: ${{ github.event.release.tag_name }} - - - name: "Build Access file (accdb/accde)" - id: build_access_file - uses: AccessCodeLib/msaccess-vcs-build@main - with: - source-dir: "./source" - target-dir: "bin" - vcs-url: "https://api.github.com/repos/josef-poetzl/msaccess-vcs-addin/releases/tags/v4.1.2-build" - timeout-minutes: 10 - - - name: "Create versioned ZIP file" - run: | - $zipName = "ACLibDeclarationDict_${{ github.event.release.tag_name }}.zip" - Compress-Archive -Path .\bin\* -DestinationPath $zipName - echo "ZIP_NAME=$zipName" | Out-File -FilePath $env:GITHUB_ENV -Append - - - name: "Upload ZIP to GitHub Release" - uses: softprops/action-gh-release@v1 - with: - files: ${{ env.ZIP_NAME }} - env: - GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - - - name: "Calculate SHA256 of ZIP" - id: hash - shell: pwsh - run: | - $zipName = "${{ env.ZIP_NAME }}" - $hash = Get-FileHash -Algorithm SHA256 -Path $zipName - $digest = "sha256:$($hash.Hash.ToLower())" - echo "ZIP_DIGEST=$digest" | Out-File -FilePath $env:GITHUB_ENV -Append - echo "digest=$digest" >> $env:GITHUB_OUTPUT - - - name: "Attestation" - uses: actions/attest-build-provenance@v2 - id: attestation - with: - subject-name: "${{ env.ZIP_NAME }}" - subject-digest: "${{ steps.hash.outputs.digest }}" - - - name: "Update release description with attestation URL" - shell: pwsh - env: - GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - REPO: ${{ github.repository }} - TAG: ${{ github.event.release.tag_name }} - run: | - $ErrorActionPreference = "Stop" - - # Alte Release Notes abrufen - $oldBody = gh release view $env:TAG --repo $env:REPO --json body --template "{{.body}}" - - # Attestation-URL zusammenbauen - $attestationId = "${{ steps.attestation.outputs.attestation-id }}" - $attestationUrl = "https://github.com/$($env:REPO)/attestations/$attestationId" - - # Neue Release Notes mit Attestation-Link - $newBody = "$oldBody`n`nAttestation: $attestationUrl" - - # Aktualisieren der Release Notes - gh release edit $env:TAG --repo $env:REPO --notes "$newBody" - - diff --git a/.github/workflows/build-release-zip-file.yml b/.github/workflows/build-release-zip-file.yml index 97d0d9e..b4f0b20 100644 --- a/.github/workflows/build-release-zip-file.yml +++ b/.github/workflows/build-release-zip-file.yml @@ -25,7 +25,7 @@ jobs: with: source-dir: "source" target-dir: "bin" - file-name: "ACLibDeclarationDictCore.accda" + file-name: "ACLibDeclarationDict.accda" run-accunit-tests: true timeout-minutes: 10 @@ -38,20 +38,11 @@ jobs: file-name: "DeclDictTester.accdb" run-accunit-tests: true timeout-minutes: 10 - - - name: "Build Example_APIusage" - id: build_example_api_usage - uses: AccessCodeLib/msaccess-vcs-build@main - with: - source-dir: "Example_APIusage.accdb.src" - target-dir: "bin" - file-name: "Example_APIusage.accdb" - timeout-minutes: 10 - name: "Create versioned ZIP file" run: | $zipName = "ACLibImportWizard_${{ github.event.release.tag_name }}.zip" - Compress-Archive -Path .\bin\*.accda, .\bin\Example_APIusage.accdb -DestinationPath $zipName + Compress-Archive -Path .\bin\*.accda -DestinationPath $zipName echo "ZIP_NAME=$zipName" | Out-File -FilePath $env:GITHUB_ENV -Append - name: "Upload ZIP to GitHub Release" diff --git a/DeclDictTester.accdb.src/modules/_LoadAddIn.bas b/DeclDictTester.accdb.src/modules/_LoadAddIn.bas index 4570456..a7acf9c 100644 --- a/DeclDictTester.accdb.src/modules/_LoadAddIn.bas +++ b/DeclDictTester.accdb.src/modules/_LoadAddIn.bas @@ -14,7 +14,7 @@ Public Sub LoadAddIn_RunVcsCheck() 'API: RunVcsCheck(Optional ByVal OpenDialogToFixLettercase As Boolean = False) Dim AddInCallPath As String - AddInCallPath = CurrentProject.Path & "\ACLibDeclarationDictCore.RunVcsCheck" + AddInCallPath = CurrentProject.Path & "\ACLibDeclarationDict.RunVcsCheck" Dim Result As Variant Result = Application.Run(AddInCallPath, True) diff --git a/Example_APIusage.accdb.src/modules/_LoadAddIn.bas b/Example_APIusage.accdb.src/modules/_LoadAddIn.bas index 4e02ab1..cbd0075 100644 --- a/Example_APIusage.accdb.src/modules/_LoadAddIn.bas +++ b/Example_APIusage.accdb.src/modules/_LoadAddIn.bas @@ -9,7 +9,7 @@ Public Sub LoadAddIn() ' Optional ByVal IncludeUsedMembers As Boolean = False) As Variant Dim AddInCallPath As String - AddInCallPath = CurrentProject.Path & "\ACLibDeclarationDictCore.RunVcsCheck" + AddInCallPath = CurrentProject.Path & "\ACLibDeclarationDict.RunVcsCheck" Dim Result As Variant Result = Application.Run(AddInCallPath, True, vbNullString, True) diff --git a/Tests/ACLibDeclarationDictCore/DeclarationDictTestCodemodule.cls b/Tests/ACLibDeclarationDict/DeclarationDictTestCodemodule.cls similarity index 100% rename from Tests/ACLibDeclarationDictCore/DeclarationDictTestCodemodule.cls rename to Tests/ACLibDeclarationDict/DeclarationDictTestCodemodule.cls diff --git a/Tests/ACLibDeclarationDictCore/DeclarationDictTests.cls b/Tests/ACLibDeclarationDict/DeclarationDictTests.cls similarity index 100% rename from Tests/ACLibDeclarationDictCore/DeclarationDictTests.cls rename to Tests/ACLibDeclarationDict/DeclarationDictTests.cls diff --git a/Tests/ACLibDeclarationDictCore/ITestInterface.cls b/Tests/ACLibDeclarationDict/ITestInterface.cls similarity index 100% rename from Tests/ACLibDeclarationDictCore/ITestInterface.cls rename to Tests/ACLibDeclarationDict/ITestInterface.cls From 34ddd848e0e70abe0ccd342fe6231792e9765ced Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Fri, 20 Jun 2025 23:50:33 +0200 Subject: [PATCH 11/13] fix core => add-in file --- .github/workflows/build-accdb.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/build-accdb.yml b/.github/workflows/build-accdb.yml index b1ffd08..e1e8440 100644 --- a/.github/workflows/build-accdb.yml +++ b/.github/workflows/build-accdb.yml @@ -28,13 +28,13 @@ jobs: with: ref: ${{ github.event.release.tag_name }} - - name: "Build add-in" + - name: "Build Add-in" id: build_add_in uses: AccessCodeLib/msaccess-vcs-build@main with: source-dir: "source" target-dir: "bin" - file-name: "ACLibDeclarationDictCore.accda" + file-name: "ACLibDeclarationDict.accda" run-accunit-tests: true timeout-minutes: 10 From bf3dca52c42bad8fed162bf2c0f7f9453d9b8e97 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Fri, 20 Jun 2025 23:57:51 +0200 Subject: [PATCH 12/13] fix: core -> add-in --- Tests/DeclDictTester/DeclDictApiTests.cls | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Tests/DeclDictTester/DeclDictApiTests.cls b/Tests/DeclDictTester/DeclDictApiTests.cls index 9ffbb82..a7e8603 100644 --- a/Tests/DeclDictTester/DeclDictApiTests.cls +++ b/Tests/DeclDictTester/DeclDictApiTests.cls @@ -7,7 +7,7 @@ Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False -Option Compare Database +Option Compare Text Option Explicit 'AccUnit:TestClass @@ -18,7 +18,7 @@ Public Sub RunVcsCheck_WithoutDialogChangedLettercase_CheckReturnMessage() Dim DictFilePath As String Dim Result As Variant - AddInCallPath = CurrentProject.Path & "\ACLibDeclarationDictCore.RunVcsCheck" + AddInCallPath = CurrentProject.Path & "\ACLibDeclarationDict.RunVcsCheck" DictFilePath = CurrentProject.Path & "\DeclDictApiTests_DeclDict.txt" ' ensure run first export => delete file if exists From 16ee45d5094043dc9c8ad669c61fc9fa4424cf0a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Sun, 29 Jun 2025 20:12:14 +0200 Subject: [PATCH 13/13] fix rebase issue --- source/forms/DeclarationDictForm.cls | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/source/forms/DeclarationDictForm.cls b/source/forms/DeclarationDictForm.cls index ae68f65..164aad1 100644 --- a/source/forms/DeclarationDictForm.cls +++ b/source/forms/DeclarationDictForm.cls @@ -103,12 +103,18 @@ Private Sub cmdChangeLetterCase_Click() End Sub Private Sub cmdUpdateDict_Click() - ActiveDeclarationDict.ImportVBProject CurrentVbProject + + With New CodemoduleDeclarationReader + .ImportVBProject CurrentVbProject, ActiveDeclarationDict, True + End With + If Not (m_InsertRecordset Is Nothing) Then m_InsertRecordset.Close Set m_InsertRecordset = Nothing End If + RequeryDictData + End Sub Private Sub lbDictData_AfterUpdate()