v1.3.2 (#8)

* v1.3.2: use %appdata%\AccessCodeLib instead of %appdata%\AccessCodeLibrary for config data

Author: josef-poetzl

access-add-in/ACLibImportWizard.accda

@@ -31,7 +31,7 @@ Option Compare Database
 Option Explicit
 
 'Versionsnummer
-Private Const APPLICATION_VERSION As String = "1.3.1"
+Private Const APPLICATION_VERSION As String = "1.3.2"
 
 #Const USE_CLASS_ApplicationHandler_AppFile = 1
 #Const USE_CLASS_ApplicationHandler_DirTextbox = 1

source/ACLibImportWizardForm.frm

@@ -12,7 +12,7 @@ Attribute VB_Description = "Konfigurationseinstellungen der CodeLib verwalten"
 ' Class: _codelib.addins.shared.ACLibConfiguration
 '---------------------------------------------------------------------------------------
 '
-' Konfigurationseinstellungen der CodeLib verwalten
+' Manage AccessCodeLib configuration settings
 '
 ' Author:
 '     Josef Poetzl
@@ -44,7 +44,8 @@ Private Const EXTENSION_KEY As String = "ACLibConfiguration"
 
 
 ' Grundeinstellungen
-Private Const ACLIB_CONFIG_ROOTFOLDERNAME As String = "AccessCodeLibrary"
+Private Const ACLIB_CONFIG_ROOTFOLDERNAME As String = "AccessCodeLib"
+Private Const ACLIB_CONFIG_ROOTFOLDERNAME_DEPR As String = "AccessCodeLibrary"
 Private Const ACLIB_CONFIG_DATABASENAME As String = "ACLib_Config"
 Private Const ACLIB_CONFIG_TABLEDEFNAME As String = "ACLib_ConfigTable"
 
@@ -174,6 +175,7 @@ Public Property Let LocalRepositoryPath(ByVal NewPath As String)
 
 End Property
 
+
 Public Property Get PrivateRepositoryPath() As String
 
    If Len(m_PrivateRepositoryPath) = 0 Then
@@ -242,7 +244,7 @@ Public Property Let GitHubAuthPersonalAccessToken(ByVal NewValue As String)
 
 End Property
 
-Private Function GetACLibGlobalProperty(ByVal PropertyName As String) As String
+Friend Function GetACLibGlobalProperty(ByRef PropertyName As String) As String
 
    Dim rst As DAO.Recordset
    Dim SelectSql As String
@@ -258,7 +260,7 @@ Private Function GetACLibGlobalProperty(ByVal PropertyName As String) As String
 
 End Function
 
-Private Function SetACLibGlobalProperty(ByVal PropertyName As String, ByVal NewValue As String) As String
+Friend Function SetACLibGlobalProperty(ByRef PropertyName As String, ByRef NewValue As String) As String
 
    Dim rst As DAO.Recordset
    Dim SelectSql As String
@@ -342,10 +344,22 @@ Public Property Get ACLibConfigDirectory() As String
 
 End Property
 
+Private Property Get ACLibConfigDirectoryDepr() As String
+   
+   Dim strPath As String
+
+   strPath = Environ("Appdata") & "\" & ACLIB_CONFIG_ROOTFOLDERNAME_DEPR & "\"
+   
+   ACLibConfigDirectoryDepr = strPath
+
+End Property
+
 Private Property Get ACLibConfigDatabaseFile() As String
 
    Dim db As DAO.Database
+   Dim strDbFileExt As String
    Dim strDbFile As String
+   Dim strDbFileDepr As String
    Dim bolCreateConfigTable As Boolean
 
 #If ADODB_EARLYBINDING = 1 Then
@@ -354,14 +368,22 @@ Private Property Get ACLibConfigDatabaseFile() As String
    Dim cnn As Object
 #End If
 
-   strDbFile = CodeDb.Name
-   strDbFile = Mid$(strDbFile, InStrRev(strDbFile, "."))
-   If Left$(strDbFile, 5) = ".accd" Then
-      strDbFile = ".accdu"
+   strDbFileExt = CodeDb.Name
+   strDbFileExt = Mid$(strDbFileExt, InStrRev(strDbFileExt, "."))
+   If Left$(strDbFileExt, 5) = ".accd" Then
+      strDbFileExt = ".accdu"
    Else
-      strDbFile = ".mdt"
+      strDbFileExt = ".mdt"
+   End If
+   strDbFile = ACLibConfigDirectory & ACLIB_CONFIG_DATABASENAME & strDbFileExt
+   
+   ' Try transfer file from deprecated folder path:
+   If Len(Dir$(strDbFile)) = 0 Then
+      strDbFileDepr = ACLibConfigDirectoryDepr & ACLIB_CONFIG_DATABASENAME & strDbFileExt
+      If Len(Dir$(strDbFileDepr)) > 0 Then
+         FileCopy strDbFileDepr, strDbFile
+      End If
    End If
-   strDbFile = ACLibConfigDirectory & ACLIB_CONFIG_DATABASENAME & strDbFile
 
    If Len(Dir$(strDbFile)) = 0 Then
 

source/_config_Application.bas

@@ -276,20 +276,22 @@ End Function
 '---------------------------------------------------------------------------------------
 Public Function ClassUsed(ByVal ClassName As String) As Boolean
 
-   Dim SearchString(5) As String
+   Dim SearchString(6) As String
    Dim i As Long
    Dim IsUsed As Boolean
-   Dim MaxCnt As Long
+   Dim MaxIndex As Long
 
    SearchString(0) = " As " & Trim$(ClassName) & vbNewLine
    SearchString(1) = " As " & Trim$(ClassName) & ","
    SearchString(2) = " As " & Trim$(ClassName) & " "
 
-   MaxCnt = 2
-   For i = 0 To MaxCnt
-      SearchString(MaxCnt + 1 + i) = " New " & Mid(SearchString(i), 5)
+   MaxIndex = 2
+   For i = 0 To MaxIndex
+      SearchString(MaxIndex + 1 + i) = " New " & Mid(SearchString(i), 5)
    Next
 
+   SearchString(6) = " " & Trim$(ClassName) & "." ' to detect the use of static classes
+   
    If StrPtr(m_CodeModuleText) = 0 Then
       m_CodeModuleText = PlainCodeText
    End If
@@ -340,11 +342,11 @@ Public Function ProcedureUsed(ByRef CodeModuleProc As CodeModuleProcedure) As Bo
    If StrPtr(m_CodeModuleText) = 0 Then
       m_CodeModuleText = PlainCodeText
    End If
-   
+
    'Text durchsuchen
    For i = LBound(SearchStringArray) To UBound(SearchStringArray)
-#If USEREGEX = 1 Then
-      With RegEx
+#If USEREGEXP = 1 Then
+      With RegExp
          .Pattern = SearchStringArray(i)
          .Global = False
          IsUsed = .Test(m_CodeModuleText)
@@ -395,7 +397,7 @@ Public Function HeaderItemUsed(ByRef HdrItm As CodeModuleHeaderItem) As Boolean
 
    For i = LBound(SearchStringArray) To UBound(SearchStringArray)
 #If USEREGEX = 1 Then
-      With RegEx
+      With RegExp
          .Pattern = SearchStringArray(i)
          .Global = False
          IsUsed = .Test(m_CodeModuleText)

source/codelib/_codelib/addins/shared/ACLibConfiguration.cls

@@ -553,6 +553,8 @@ 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
@@ -564,21 +566,20 @@ Friend Function ConvertToNumeric(ByVal Value As Variant) As Variant
 
    CheckText = CStr(CheckNumber)
    If InStr(1, CheckText, ",") > 0 Then
-      If InStr(1, Value, ".") > 0 Then
-         Value = Replace(Value, ".", ",")
-         Do While Value Like "*,*,*"
-            Value = Replace(Value, ",", vbNullString, 1, 1)
-         Loop
-      End If
+      DecimalSeparatorToReplace = "."
+      NewDecimalSeparator = ","
    Else
-      If InStr(1, Value, ",") > 0 Then
-         Value = Replace(Value, ",", ".")
-         Do While Value Like "*.*.*"
-            Value = Replace(Value, ".", vbNullString, 1, 1)
-         Loop
-      End If
+      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

source/codelib/_codelib/addins/shared/CodeModuleReader.cls

@@ -21,7 +21,6 @@ Attribute VB_Exposed = False
 '---------------------------------------------------------------------------------------
 '<codelib>
 '  <file>data/dao/DaoHandler.cls</file>
-'  <description>DAO data connection methods</description>
 '  <license>_codelib/license.bas</license>
 '  <ref><name>DAO</name><major>5</major><minor>0</minor><guid>{00025E01-0000-0000-C000-000000000046}</guid></ref>
 '  <test>_test/data/dao/DaoHandlerTests.cls</test>
@@ -781,21 +780,21 @@ Public Function LookupSql(ByVal SqlText As String, _
                  Optional ByVal Index As Variant = 0&, _
                  Optional ByVal ValueIfNull As Variant = Null) As Variant
 
-    Dim rst As DAO.Recordset
+   Dim rst As DAO.Recordset
 
 On Error GoTo HandleErr
 
-    Set rst = Me.OpenRecordset(SqlText, dbOpenForwardOnly, dbSeeChanges, dbReadOnly)
-    With rst
-        If .EOF Then
-            LookupSql = ValueIfNull
-        Else
-            LookupSql = Nz(.Fields(Index), ValueIfNull)
-        End If
-        .Close
-    End With
-    Set rst = Nothing
-
+   Set rst = Me.OpenRecordset(SqlText, dbOpenForwardOnly, dbSeeChanges, dbReadOnly)
+   With rst
+      If .EOF Then
+         LookupSql = ValueIfNull
+      Else
+         LookupSql = Nz(.Fields(Index), ValueIfNull)
+      End If
+      .Close
+   End With
+   Set rst = Nothing
+   
 ExitHere:
    Exit Function
 
@@ -804,7 +803,7 @@ HandleErr:
       rst.Close
       Set rst = Nothing
    End If
-
+   
    Err.Raise Err.Number, "LookupSQL:" & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
 
 End Function
@@ -829,15 +828,30 @@ Public Function Lookup(ByVal Expr As String, ByVal Domain As String, _
               Optional ByVal Criteria As Variant, _
               Optional ByVal ValueIfNull As Variant = Null) As Variant
 
-    Dim SelectSql As String
+   Dim SelectSql As String
 
-    SelectSql = "SELECT " & Expr & " FROM (" & Domain & ")"
-    If Not (VarType(Criteria) = vbError) Then
-        If Len(Criteria) > 0 Then
-            SelectSql = SelectSql & " WHERE " & Criteria
-        End If
-    End If
-    Lookup = LookupSql(SelectSql, , ValueIfNull)
+   SelectSql = BuildSelectSql(Expr, Domain, Criteria, False)
+   Lookup = LookupSql(SelectSql, , ValueIfNull)
+
+End Function
+
+Private Function BuildSelectSql(ByVal Expr As String, ByVal Domain As String, Optional ByVal Criteria As Variant, _
+                       Optional ByVal Distinct As Boolean = False)
+
+   Dim SelectSql As String
+
+   SelectSql = "SELECT "
+   If Distinct Then
+      SelectSql = SelectSql & "Distinct "
+   End If
+   SelectSql = SelectSql & Expr & " FROM (" & Domain & ")"
+   If Not (VarType(Criteria) = vbError) Then
+      If Len(Criteria) > 0 Then
+         SelectSql = SelectSql & " WHERE " & Criteria
+      End If
+   End If
+   
+   BuildSelectSql = SelectSql
 
 End Function
 
@@ -856,8 +870,18 @@ End Function
 '     Long
 '
 '---------------------------------------------------------------------------------------
-Public Function Count(ByVal Expr As String, ByVal Domain As String, Optional ByVal Criteria As Variant) As Long
-    Count = Nz(Me.Lookup("Count(" & Expr & ")", Domain, Criteria), 0)
+Public Function Count(ByVal Expr As String, ByVal Domain As String, Optional ByVal Criteria As Variant, _
+             Optional ByVal Distinct As Boolean = False) As Long
+             
+   If Distinct Then
+      If Expr <> "*" Then
+         Domain = "(" & BuildSelectSql(Expr, Domain, Criteria, True) & ")"
+         Criteria = vbNullString
+      End If
+   End If
+             
+   Count = Nz(Me.Lookup("Count(" & Expr & ")", Domain, Criteria), 0)
+   
 End Function
 
 '---------------------------------------------------------------------------------------
@@ -960,7 +984,7 @@ End Function
 '     Works for Jet only from Jet 4.0 (Access 2000), IdentityTable is only applicable for MSSQL, under MySQL the IDENT_CURRENT function does not exist.
 '     (<data.adodb.AdodbHandler::InsertIdentityReturn> is more suitable regarding use for active DBMS.)
 '---------------------------------------------------------------------------------------
-Public Function InsertIdentityReturn(ByVal InsertSql As String) As Variant
+Public Function InsertIdentityReturn(ByVal InsertSQL As String) As Variant
 
     Dim db As DAO.Database
     Dim rst As DAO.Recordset
@@ -969,7 +993,7 @@ Public Function InsertIdentityReturn(ByVal InsertSql As String) As Variant
 On Error GoTo HandleErr
 
     Set db = Me.CurrentDb
-    db.Execute InsertSql
+    db.Execute InsertSQL
     RecordsAffected = db.RecordsAffected
 
     If RecordsAffected = 0 Then

source/codelib/data/SqlTools.cls

@@ -576,7 +576,6 @@ ExitHere:
 HandleErr:
    Select Case Err.Number
    Case 3376 'Table does not exist.
-      Err.Raise 123, Err.Source, Err.Description
       Resume ExitHere
    Case Else
       Err.Raise Err.Number, Err.Source, Err.Description

source/codelib/data/dao/DaoHandler.cls

@@ -9,6 +9,10 @@ Attribute VB_Description = "String-Hilfsfunktionen"
 ' Author:
 '     Josef Poetzl, Sten Schmidt
 '
+' Remarks:
+'     Use DisableReplaceVbaStringFunctions = 1 in conditional compilation arguments (in vbe project properties)
+'     to disable replacement of VBA.Format function
+'
 '---------------------------------------------------------------------------------------
 
 '---------------------------------------------------------------------------------------
@@ -124,9 +128,17 @@ End Function
 '     String
 '
 '---------------------------------------------------------------------------------------
+#If DisableReplaceVbaStringFunctions = 0 Then
 Public Function Format(ByVal Expression As Variant, Optional ByVal FormatString As Variant, _
               Optional ByVal FirstDayOfWeek As VbDayOfWeek = vbSunday, _
               Optional ByVal FirstWeekOfYear As VbFirstWeekOfYear = vbFirstJan1) As String
+   Format = FormatX(Expression, FormatString, FirstDayOfWeek, FirstWeekOfYear)
+End Function
+#End If
+
+Public Function FormatX(ByVal Expression As Variant, Optional ByVal FormatString As Variant, _
+              Optional ByVal FirstDayOfWeek As VbDayOfWeek = vbSunday, _
+              Optional ByVal FirstWeekOfYear As VbFirstWeekOfYear = vbFirstJan1) As String
 
    Dim Hours As Long
 
@@ -151,7 +163,7 @@ Public Function Format(ByVal Expression As Variant, Optional ByVal FormatString
       End If
    End If
 
-   Format = VBA.Format$(Expression, FormatString, FirstDayOfWeek, FirstWeekOfYear)
+   FormatX = VBA.Format$(Expression, FormatString, FirstDayOfWeek, FirstWeekOfYear)
 
 End Function