diff --git a/.gitignore b/.gitignore index fe82cce..10ca69c 100644 --- a/.gitignore +++ b/.gitignore @@ -21,3 +21,10 @@ 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 + +# 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": { 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/modVbProject.bas b/source/modVbProject.bas new file mode 100644 index 0000000..c1a3705 --- /dev/null +++ b/source/modVbProject.bas @@ -0,0 +1,92 @@ +Attribute VB_Name = "modVbProject" +'--------------------------------------------------------------------------------------- +' Module: modVbProject +'--------------------------------------------------------------------------------------- +'/** +' +' VBProject ermitteln +' +' +' +' \ingroup base +'**/ +'--------------------------------------------------------------------------------------- +' +' %AppFolder%/source/modVbProject.bas +' _codelib/license.bas +' +'--------------------------------------------------------------------------------------- +' +Option Compare Text +Option Explicit +Option Private Module + +#Const EARLYBINDING = 1 + +Private m_CurrentVbProject As Object + +#If EARLYBINDING Then +Public Property Get CurrentVbProject() As VBIDE.VBProject +#Else +Public Property Get CurrentVbProject() As Object +#End If + +#If EARLYBINDING Then + Dim Proj As VBProject +#Else + Dim Proj As Object +#End If + Dim strCurrentDbName As String + + If m_CurrentVbProject Is Nothing Then + Set m_CurrentVbProject = Application.VBE.ActiveVBProject + If Application.VBE.VBProjects.Count > 1 Then + 'Prüfen, ob das richtige VbProject gewählt wurde (muss das von CurrentDb sein) + strCurrentDbName = UncPath(CurrentDb.Name) + If m_CurrentVbProject.FileName <> strCurrentDbName Then + Set m_CurrentVbProject = Nothing + For Each Proj In VBE.VBProjects + If Proj.FileName = strCurrentDbName Then + Set m_CurrentVbProject = Proj + Exit For + End If + Next + End If + End If + End If + + Set CurrentVbProject = m_CurrentVbProject + +End Property + + +#If EARLYBINDING Then +Public Property Get CodeVBProject() As VBIDE.VBProject +#Else +Public Property Get CodeVBProject() As Object +#End If + +#If EARLYBINDING Then + Dim Proj As VBProject +#Else + Dim Proj As Object +#End If + Dim strCodeDbName As String + Dim objCodeVbProject As Object + + Set objCodeVbProject = VBE.ActiveVBProject + 'Prüfen, ob das richtige VbProject gewählt wurde (muss das von CodeDb sein) + strCodeDbName = FileTools.UncPath(CodeDb.Name) + If objCodeVbProject.FileName <> strCodeDbName Then + Set objCodeVbProject = Nothing + For Each Proj In VBE.VBProjects + If Proj.FileName = strCodeDbName Then + Set objCodeVbProject = Proj + Exit For + End If + Next + End If + + Set CodeVBProject = objCodeVbProject + +End Property 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..47cfcd9 --- /dev/null +++ b/source/modules/CodemoduleDeclarationReader.cls @@ -0,0 +1,231 @@ +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, Optional ByVal IncludeUsedMembers As Boolean = False) + + Dim vbc As VBComponent + + For Each vbc In VBProject2Import.VBComponents + ImportVBComponent vbc, DeclDict, IncludeUsedMembers + Next + +End Sub + +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, Optional ByVal IncludeUsedMembers As Boolean = False) + If CodeModule2Import.CountOfLines > 0 Then + ImportCode CodeModule2Import.Lines(1, CodeModule2Import.CountOfLines), DeclDict, IncludeUsedMembers + End If +End Sub + +Public Sub ImportCode(ByVal Code As String, ByVal DeclDict As DeclarationDict, Optional ByVal IncludeUsedMembers As Boolean = False) + + 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 + Const DimIndex As Long = 2 + + 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, i = DimIndex + 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, 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, IsDimBlock + Next + Next + +End Sub + +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 + 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 IsDimBlock 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..3c36860 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,240 +141,28 @@ 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 + Dim IdxWordKey As Variant Dim WordIndex As Long - Dim VariationsDict As Scripting.Dictionary + Dim IdxVariationsDict As Scripting.Dictionary Dim OutputString As String For WordIndex = 0 To m_Words.Count - 1 - WordKey = m_Words.Keys(WordIndex) - Set VariationsDict = m_Words.Item(WordKey) + IdxWordKey = m_Words.Keys(WordIndex) + Set IdxVariationsDict = m_Words.Item(IdxWordKey) - If VariationsDict.Count > (1 - Abs(ShowAll)) Then - OutputString = OutputString & vbNewLine & WordKey & ":" & GetWordVariationsOutputString(WordKey) + If IdxVariationsDict.Count > (1 - Abs(ShowAll)) Then + OutputString = OutputString & vbNewLine & IdxWordKey & ":" & GetWordVariationsOutputString(IdxWordKey) End If Next @@ -383,12 +173,12 @@ End Function Public Function ToDict(Optional ByVal ShowAll As Boolean = False) As Scripting.Dictionary - Dim WordKey As Variant + Dim IdxWordKey As Variant Dim WordIndex As Long Dim OutputWord As Boolean Dim VariationsString As String - Dim VariationsDict As Scripting.Dictionary + Dim IdxVariationsDict As Scripting.Dictionary Dim OutputDict As Scripting.Dictionary Set OutputDict = New Scripting.Dictionary @@ -397,19 +187,19 @@ Public Function ToDict(Optional ByVal ShowAll As Boolean = False) As Scripting.D For WordIndex = 0 To m_Words.Count - 1 - WordKey = m_Words.Keys(WordIndex) - Set VariationsDict = m_WordVariations.Item(WordKey) + IdxWordKey = m_Words.Keys(WordIndex) + Set IdxVariationsDict = m_WordVariations.Item(IdxWordKey) If Not ShowAll Then - OutputWord = IsChangedItem(WordKey, VariationsDict) + OutputWord = IsChangedItem(IdxWordKey, VariationsDict) End If If OutputWord Then - If VariationsDict.Count > 1 Then - VariationsString = GetWordVariationsOutputString(WordKey) + If IdxVariationsDict.Count > 1 Then + VariationsString = GetWordVariationsOutputString(IdxWordKey) Else VariationsString = vbNullString End If - OutputDict.Add WordKey, VariationsString + OutputDict.Add IdxWordKey, VariationsString End If Next @@ -430,19 +220,19 @@ Public Function GetWordVariations(ByVal Word As String, Optional ByVal IgnoreOri Dim VariantWord As String Dim AppendVariant As Boolean Dim i As Long, k As Long - Dim VariationsDict As Scripting.Dictionary + Dim WordVariationsDict As Scripting.Dictionary If StrComp(Word, m_Words.Item(Word), vbBinaryCompare) <> 0 Then Word = m_Words.Item(Word) End If - Set VariationsDict = m_WordVariations.Item(Word) - ReDim Variations(VariationsDict.Count - 1 - Abs(IgnoreOriginalWord)) + Set WordVariationsDict = m_WordVariations.Item(Word) + ReDim Variations(WordVariationsDict.Count - 1 - Abs(IgnoreOriginalWord)) AppendVariant = Not IgnoreOriginalWord - For i = 0 To VariationsDict.Count - 1 - VariantWord = VariationsDict.Keys(i) + For i = 0 To WordVariationsDict.Count - 1 + VariantWord = WordVariationsDict.Keys(i) If IgnoreOriginalWord Then AppendVariant = StrComp(Word, VariantWord, vbBinaryCompare) <> 0 End If @@ -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..adaa21a 100644 --- a/source/modules/FileTools.bas +++ b/source/modules/FileTools.bas @@ -26,12 +26,12 @@ Option Private Module #If USELOCALIZATION_DE = 1 Then Private Const SELECTBOX_FILE_DIALOG_TITLE As String = "Datei auswählen" Private Const SELECTBOX_FOLDER_DIALOG_TITLE As String = "Ordner auswählen" -Private Const SELECTBOX_OPENTITLE As String = "auswählen" +Private Const SELECTBOX_OPENTITLE As String = "Auswählen" Private Const FILTERSTRING_ALL_FILES As String = "Alle Dateien (*.*)" #Else Private Const SELECTBOX_FILE_DIALOG_TITLE As String = "Select file" Private Const SELECTBOX_FOLDER_DIALOG_TITLE As String = "Select folder" -Private Const SELECTBOX_OPENTITLE As String = "auswählen" +Private Const SELECTBOX_OPENTITLE As String = "Select" Private Const FILTERSTRING_ALL_FILES As String = "All Files (*.*)" #End If @@ -43,8 +43,6 @@ Private Const SE_ERR_NOASSOC As Long = 31 Private Const VbaErrNo_FileNotFound As Long = 53 -#If VBA7 Then - Private Declare PtrSafe Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" ( _ ByVal lpszLocalName As String, ByVal lpszRemoteName As String, cbRemoteName As Long) As Long @@ -66,30 +64,6 @@ Private Declare PtrSafe Function API_ShellExecuteA Lib "shell32.dll" Alias "Shel ByVal lpDirectory As String, _ ByVal nShowCmd As Long) As Long -#Else - -Private Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" ( _ - ByVal lpszLocalName As String, ByVal lpszRemoteName As String, cbRemoteName As Long) As Long - -Private Declare Function API_GetTempPath Lib "kernel32" Alias "GetTempPathA" ( _ - ByVal nBufferLength As Long, _ - ByVal lpBuffer As String) As Long - -Private Declare Function API_GetTempFilename Lib "kernel32" Alias "GetTempFileNameA" ( _ - ByVal lpszPath As String, _ - ByVal lpPrefixString As String, _ - ByVal wUnique As Long, _ - ByVal lpTempFileName As String) As Long - -Private Declare Function API_ShellExecuteA Lib "shell32.dll" Alias "ShellExecuteA" ( _ - ByVal Hwnd As Long, _ - ByVal lOperation As String, _ - ByVal lpFile As String, _ - ByVal lpParameters As String, _ - ByVal lpDirectory As String, _ - ByVal nShowCmd As Long) As Long - -#End If '--------------------------------------------------------------------------------------- ' Function: SelectFile @@ -753,7 +727,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 +749,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..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 @@ -51,52 +52,60 @@ Public Function RunVcsCheck(Optional ByVal OpenDialogToFixLettercase As Boolean Dim StoreDictData As Boolean Dim IntialCnt As Long - With New DeclarationDict + Dim DeclDict As DeclarationDict + Set DeclDict = New DeclarationDict - If Len(DeclDictFilePath) = 0 Then - DeclDictFilePath = CurrentProject.Path & "\" & CurrentProject.Name & ".DeclarationDict.txt" - End If + 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 - End If + If Not DeclDict.LoadFromFile(DeclDictFilePath) Then + ImportVBProject CurrentVbProject, DeclDict, IncludeUsedMembers + ' ... log info: first export + DeclDict.ExportToFile DeclDictFilePath + RunVcsCheck = "Info: No dictionary data found. A new dictionary has been created." + Exit Function + End If - IntialCnt = .Count - .ImportVBProject CurrentVbProject + IntialCnt = DeclDict.Count + ImportVBProject CurrentVbProject, DeclDict, IncludeUsedMembers - DiffCnt = .DiffCount - If DiffCnt = 0 Then - If .Count <> IntialCnt Then - StoreDictData = True - End If + DiffCnt = DeclDict.DiffCount + If DiffCnt = 0 Then + If DeclDict.Count <> IntialCnt Then + StoreDictData = True 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 + 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 StoreDictData Then - .ExportToFile DeclDictFilePath - End If + If StoreDictData Then + DeclDict.ExportToFile DeclDictFilePath + 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 + 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 + +End Function + +Private Sub ImportVBProject(ByVal VbProjectToImport As VBIDE.VBProject, ByVal DeclDict As DeclarationDict, _ + Optional ByVal IncludeUsedMembers As Boolean = False) + With New CodemoduleDeclarationReader + .ImportVBProject VbProjectToImport, DeclDict, IncludeUsedMembers End With -End Function +End Sub diff --git a/source/modules/modSort.bas b/source/modules/modSort.bas index 51e5682..821becc 100644 --- a/source/modules/modSort.bas +++ b/source/modules/modSort.bas @@ -1,5 +1,5 @@ Attribute VB_Name = "modSort" -Option Compare Database +Option Compare Text Option Explicit Public Sub QuickSort(ByRef ArrToSort As Variant, ByVal FirstIndex As Long, ByVal LastIndex As Long) 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": {