diff --git a/access-add-in/AccUnitLoader.accda b/access-add-in/AccUnitLoader.accda index 2be2f0c..a6012c5 100644 Binary files a/access-add-in/AccUnitLoader.accda and b/access-add-in/AccUnitLoader.accda differ diff --git a/access-add-in/New Text Document.txt b/access-add-in/New Text Document.txt new file mode 100644 index 0000000..1c5a0cd --- /dev/null +++ b/access-add-in/New Text Document.txt @@ -0,0 +1,10 @@ +Public Sub {MethodUnderTest}_{StateUnderTest}_{ExpectedBehaviour}({Params}) + ' Arrange + Err.Raise vbObjectError, "{MethodUnderTest}_{StateUnderTest}_{ExpectedBehaviour}", "Test not implemented" + Const Expected As Variant = "expected value" + Dim Actual As Variant + ' Act + Actual = "actual value" + ' Assert + Assert.That Actual, Iz.EqualTo(Expected) +End Sub diff --git a/access-add-in/source/AccUnitConfiguration.cls b/access-add-in/source/AccUnitConfiguration.cls index ba68340..33c4b09 100644 --- a/access-add-in/source/AccUnitConfiguration.cls +++ b/access-add-in/source/AccUnitConfiguration.cls @@ -40,25 +40,9 @@ Private Const EXTENSION_KEY As String = "AccUnitConfiguration" #Const ADODB_EARLYBINDING = 0 'ADODB wird hier über Late binding eingesetzt, da es nur zum Erstellen der Tabelle genutzt wird +Private m_ACLibConfig As ACLibConfiguration -' Grundeinstellungen -Private Const ACLIB_CONFIG_ROOTFOLDERNAME As String = "AccessCodeLibrary" -Private Const ACLIB_CONFIG_DATABASENAME As String = "ACLib_Config" -Private Const ACLIB_CONFIG_TABLEDEFNAME As String = "ACLib_ConfigTable" - -Private Const SQL_CONFIG_TABLE_FIELD_PROPNAME As String = "PropName" -Private Const SQL_CONFIG_TABLE_FIELD_PROPVALUE As String = "PropValue" -Private Const SQL_SELECT_PROPERTYVALUE As String = _ - "select " & SQL_CONFIG_TABLE_FIELD_PROPNAME & ", " & SQL_CONFIG_TABLE_FIELD_PROPVALUE & _ - " From " & ACLIB_CONFIG_TABLEDEFNAME & " where " & SQL_CONFIG_TABLE_FIELD_PROPNAME & " = [?]" - -Private Const SQL_CREATETABLE_CONFIGTABLE As String = _ - "CREATE TABLE " & ACLIB_CONFIG_TABLEDEFNAME & _ - "([PropName] varchar(255) WITH COMPRESSION NOT NULL," & _ - " [PropValue] varchar(255) WITH COMPRESSION," & _ - " [PropRemarks] text WITH COMPRESSION," & _ - " CONSTRAINT PK_" & ACLIB_CONFIG_TABLEDEFNAME & " PRIMARY KEY ([PropName]))" - +' Base config Private Const PROPNAME_ACCUNITDLLPATH As String = "AccUnitDllPath" ' Hilfsvariablen @@ -115,9 +99,17 @@ End Sub '--------------------------------------------------------------------------------------- -' Ergänzungen für Ereiterung: AccUnitConfiguration +' Ergänzungen für Erweiterung: AccUnitConfiguration '--------------------------------------------------------------------------------------- + +Public Property Get ACLibConfig() As ACLibConfiguration + If m_ACLibConfig Is Nothing Then + Set m_ACLibConfig = New ACLibConfiguration + End If + Set ACLibConfig = m_ACLibConfig +End Property + Private Sub GetExtensionPropertyLookup(ByVal PropertyName As String, ByRef ResumeMode As ApplicationHandlerResumeModes, ByRef ResumeMessage As Variant) ResumeMode = AppResumeMode_Completed @@ -140,7 +132,7 @@ End Property Public Property Get AccUnitDllPath() As String If Len(m_AccUnitDllPath) = 0 Then - m_AccUnitDllPath = GetACLibGlobalProperty(PROPNAME_ACCUNITDLLPATH) + m_AccUnitDllPath = ACLibConfig.GetACLibGlobalProperty(PROPNAME_ACCUNITDLLPATH) If Len(m_AccUnitDllPath) > 0 Then If Not DirExists(m_AccUnitDllPath) Then Err.Raise vbObjectError, "AccUnitConfiguration.AccUnitDllPath", "Das Verzeichnis '" & m_AccUnitDllPath & "' ist nicht vorhanden!" @@ -148,7 +140,7 @@ Public Property Get AccUnitDllPath() As String End If If VBA.Right$(m_AccUnitDllPath, 1) <> "\" Then m_AccUnitDllPath = m_AccUnitDllPath & "\" - SetACLibGlobalProperty PROPNAME_ACCUNITDLLPATH, m_AccUnitDllPath + ACLibConfig.SetACLibGlobalProperty PROPNAME_ACCUNITDLLPATH, m_AccUnitDllPath End If End If End If @@ -169,180 +161,10 @@ Public Property Let AccUnitDllPath(ByVal NewPath As String) End If End If m_AccUnitDllPath = NewPath - SetACLibGlobalProperty PROPNAME_ACCUNITDLLPATH, m_AccUnitDllPath + ACLibConfig.SetACLibGlobalProperty PROPNAME_ACCUNITDLLPATH, m_AccUnitDllPath End Property Private Property Get DefaultAccUnitDllPath() As String DefaultAccUnitDllPath = DefaultAccUnitLibFolder & "\" End Property - -Private Function GetACLibGlobalProperty(ByRef PropertyName As String) As String - - Dim rst As DAO.Recordset - Dim SelectSql As String - - SelectSql = Replace(SQL_SELECT_PROPERTYVALUE, "[?]", DaoSqlTool.TextToSqlText(PropertyName)) - Set rst = ACLibPropertyDb.OpenRecordset(SelectSql) - If Not rst.EOF Then - GetACLibGlobalProperty = Nz(rst.Fields(SQL_CONFIG_TABLE_FIELD_PROPVALUE), vbNullString) - Else - GetACLibGlobalProperty = vbNullString - End If - rst.Close - -End Function - -Private Function SetACLibGlobalProperty(ByRef PropertyName As String, ByRef NewValue As String) As String - - Dim rst As DAO.Recordset - Dim SelectSql As String - - SelectSql = Replace(SQL_SELECT_PROPERTYVALUE, "[?]", DaoSqlTool.TextToSqlText(PropertyName)) - Set rst = ACLibPropertyDb.OpenRecordset(SelectSql) - If rst.EOF Then - rst.AddNew - rst.Fields(SQL_CONFIG_TABLE_FIELD_PROPNAME).Value = PropertyName - Else - rst.Edit - End If - rst.Fields(SQL_CONFIG_TABLE_FIELD_PROPVALUE).Value = NewValue - rst.Update - rst.Close - -End Function - -Private Property Get ACLibPropertyDb() As DAO.Database - - If m_ACLibPropertyDb Is Nothing Then - If CheckConfigTableDef Then - Set m_ACLibPropertyDb = CodeDb - End If - End If - Set ACLibPropertyDb = m_ACLibPropertyDb - -End Property - -#If ADODB_EARLYBINDING Then -Private Function CreateConfigTable(ByRef TargetConnection As ADODB.Connection) As Boolean -#Else -Private Function CreateConfigTable(ByRef TargetConnection As Object) As Boolean -#End If - - TargetConnection.Execute SQL_CREATETABLE_CONFIGTABLE - CreateConfigTable = True - -End Function - - -Private Function CheckConfigTableDef() As Boolean - - Dim db As DAO.Database - Dim tdf As DAO.TableDef - - Set db = CodeDb - - If Not TableDefExists(ACLIB_CONFIG_TABLEDEFNAME, db) Then - - Set tdf = db.CreateTableDef(ACLIB_CONFIG_TABLEDEFNAME) - tdf.Connect = ";Database=" & ACLibConfigDatabaseFile - tdf.SourceTableName = ACLIB_CONFIG_TABLEDEFNAME - db.TableDefs.Append tdf - - ElseIf Len(VBA.Dir$(VBA.Mid$(db.TableDefs(ACLIB_CONFIG_TABLEDEFNAME).Connect, VBA.Len(";Database=") + 1))) = 0 Then - - With db.TableDefs(ACLIB_CONFIG_TABLEDEFNAME) - .Connect = ";Database=" & ACLibConfigDatabaseFile - .RefreshLink - End With - - End If - - Set db = Nothing - - CheckConfigTableDef = True - -End Function - -Public Property Get ACLibConfigDirectory() As String - - Dim strPath As String - - strPath = VBA.Environ("Appdata") & "\" & ACLIB_CONFIG_ROOTFOLDERNAME & "\" - If Len(VBA.Dir$(strPath, vbDirectory)) = 0 Then - VBA.MkDir strPath - End If - - ACLibConfigDirectory = strPath - -End Property - -Private Property Get ACLibConfigDatabaseFile() As String - - Dim db As DAO.Database - Dim strDbFile As String - Dim bolCreateConfigTable As Boolean - -#If ADODB_EARLYBINDING = 1 Then - Dim cnn As ADODB.Connection -#Else - Dim cnn As Object -#End If - - strDbFile = CodeDb.Name - strDbFile = VBA.Mid$(strDbFile, VBA.InStrRev(strDbFile, ".")) - If VBA.Left$(strDbFile, 5) = ".accd" Then - strDbFile = ".accdu" - Else - strDbFile = ".mdt" - End If - strDbFile = ACLibConfigDirectory & ACLIB_CONFIG_DATABASENAME & strDbFile - - If Len(VBA.Dir$(strDbFile)) = 0 Then - - 'Datenbank anlegen - If CodeDb.Version = "4.0" Then - Set db = DBEngine.CreateDatabase(strDbFile, dbLangGeneral, dbVersion40) - Else - Set db = DBEngine.CreateDatabase(strDbFile, dbLangGeneral) - End If - db.Close - - bolCreateConfigTable = True - - Else 'Prüfen ob Config-Tabelle vorhanden ist - - Set db = DBEngine.OpenDatabase(strDbFile) - bolCreateConfigTable = Not TableDefExists(ACLIB_CONFIG_TABLEDEFNAME, db) - db.Close - - End If - - If bolCreateConfigTable Then - 'Tabelle erstellen -#If ADODB_EARLYBINDING = 1 Then - Set cnn = New ADODB.Connection -#Else - Set cnn = CreateObject("ADODB.Connection") -#End If - cnn.ConnectionString = VBA.Replace(CodeProject.Connection.ConnectionString, CodeDb.Name, strDbFile) - cnn.Open - CreateConfigTable cnn - cnn.Close - Set cnn = Nothing - End If - - ACLibConfigDatabaseFile = strDbFile - -End Property - -Private Property Get DaoSqlTool() - If m_DaoSqlTools Is Nothing Then - Set m_DaoSqlTools = SqlTools.Clone("\#yyyy-mm-dd\#", "True", "*") - End If - Set DaoSqlTool = m_DaoSqlTools -End Property - -Private Sub Class_Terminate() - Set m_DaoSqlTools = Nothing -End Sub diff --git a/access-add-in/source/AccUnitLoaderFactoryCall.bas b/access-add-in/source/AccUnitLoaderFactoryCall.bas new file mode 100644 index 0000000..85b5fc1 --- /dev/null +++ b/access-add-in/source/AccUnitLoaderFactoryCall.bas @@ -0,0 +1,17 @@ +Attribute VB_Name = "AccUnitLoaderFactoryCall" +'--------------------------------------------------------------------------------------- +' Modul: AccUnitLoaderFactoryCall +'--------------------------------------------------------------------------------------- +' +' %AppFolder%/source/GetAccUnitFactory.bas +' _codelib/license.bas +' %AppFolder%/source/AccUnitLoaderFactory.cls +' +'--- +Option Compare Database +Option Explicit + +Public Function GetAccUnitFactory() As AccUnitLoaderFactory + CheckAccUnitTypeLibFile + Set GetAccUnitFactory = New AccUnitLoaderFactory +End Function diff --git a/access-add-in/source/AccUnitLoaderForm.frm b/access-add-in/source/AccUnitLoaderForm.frm index fc576bf..1a99c0a 100644 Binary files a/access-add-in/source/AccUnitLoaderForm.frm and b/access-add-in/source/AccUnitLoaderForm.frm differ diff --git a/access-add-in/source/AccUnitUserSettings.frm b/access-add-in/source/AccUnitUserSettings.frm new file mode 100644 index 0000000..a42de30 Binary files /dev/null and b/access-add-in/source/AccUnitUserSettings.frm differ diff --git a/access-add-in/source/DebugPrintTestSuite.cls b/access-add-in/source/DebugPrintTestSuite.cls index 8e61ba9..71a0373 100644 --- a/access-add-in/source/DebugPrintTestSuite.cls +++ b/access-add-in/source/DebugPrintTestSuite.cls @@ -104,13 +104,13 @@ Private Function IAccessTestSuite_Add(ByVal testToAdd As Object) As AccUnit.IAcc Set IAccessTestSuite_Add = Add(testToAdd) End Function -Public Function AddByClassName(ByVal className As String) As DebugPrintTestSuite - m_TestSuite.AddByClassName className +Public Function AddByClassName(ByVal ClassName As String) As DebugPrintTestSuite + m_TestSuite.AddByClassName ClassName Set AddByClassName = Me End Function -Private Function IAccessTestSuite_AddByClassName(ByVal className As String) As AccUnit.IAccessTestSuite - Set IAccessTestSuite_AddByClassName = AddByClassName(className) +Private Function IAccessTestSuite_AddByClassName(ByVal ClassName As String) As AccUnit.IAccessTestSuite + Set IAccessTestSuite_AddByClassName = AddByClassName(ClassName) End Function Public Function AddFromVBProject() As DebugPrintTestSuite diff --git a/access-add-in/source/_config_Application.bas b/access-add-in/source/_config_Application.bas index 95675e0..250bf1e 100644 --- a/access-add-in/source/_config_Application.bas +++ b/access-add-in/source/_config_Application.bas @@ -4,8 +4,6 @@ Attribute VB_Name = "_config_Application" '--------------------------------------------------------------------------------------- '--------------------------------------------------------------------------------------- ' -' %AppFolder%/source/_config_Application.bas -' base/_config_Application.bas ' _codelib/license.bas ' %AppFolder%/source/defGlobal_AccUnitLoader.bas ' base/modApplication.bas @@ -20,7 +18,7 @@ Option Compare Database Option Explicit 'Version nummer -Private Const APPLICATION_VERSION As String = "0.9.17.230817" +Private Const APPLICATION_VERSION As String = "0.9.18.231106" Private Const APPLICATION_NAME As String = "ACLib AccUnit Loader" Private Const APPLICATION_FULLNAME As String = "Access Code Library - AccUnit Loader" diff --git a/access-add-in/source/codelib/_codelib/addins/shared/ACLibConfiguration.cls b/access-add-in/source/codelib/_codelib/addins/shared/ACLibConfiguration.cls index ed90d8d..584336b 100644 --- a/access-add-in/source/codelib/_codelib/addins/shared/ACLibConfiguration.cls +++ b/access-add-in/source/codelib/_codelib/addins/shared/ACLibConfiguration.cls @@ -9,16 +9,16 @@ Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Attribute VB_Description = "Konfigurationseinstellungen der CodeLib verwalten" '--------------------------------------------------------------------------------------- -' Klassenmodul: ACLibConfiguration (Josef Pötzl, 2009-12-11) +' Class: _codelib.addins.shared.ACLibConfiguration '--------------------------------------------------------------------------------------- -'/** -' +' ' Konfigurationseinstellungen der CodeLib verwalten -' -' -' -'\ingroup addins_shared -'**/ +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + '--------------------------------------------------------------------------------------- ' ' _codelib/addins/shared/ACLibConfiguration.cls @@ -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" @@ -224,7 +225,7 @@ Public Property Let ImportTestsDefaultValue(ByVal NewValue As Boolean) End Property -Private Function GetACLibGlobalProperty(ByRef PropertyName As String) As String +Friend Function GetACLibGlobalProperty(ByRef PropertyName As String) As String Dim rst As DAO.Recordset Dim SelectSql As String @@ -240,7 +241,7 @@ Private Function GetACLibGlobalProperty(ByRef PropertyName As String) As String End Function -Private Function SetACLibGlobalProperty(ByRef PropertyName As String, ByRef 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 @@ -324,10 +325,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 @@ -336,14 +349,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 diff --git a/access-add-in/source/codelib/api/winapi/WinApiFileInfo.cls b/access-add-in/source/codelib/api/winapi/WinApiFileInfo.cls index d1d4641..36a9c7b 100644 --- a/access-add-in/source/codelib/api/winapi/WinApiFileInfo.cls +++ b/access-add-in/source/codelib/api/winapi/WinApiFileInfo.cls @@ -8,16 +8,16 @@ Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False '--------------------------------------------------------------------------------------- -' Class: WinApiFileInfo +' Class: api.winapi.WinApiFileInfo '--------------------------------------------------------------------------------------- -'/** -' -' Dateiinformationen mit Win-API auslesen -' -' -' -'\ingroup WinAPI -'**/ +' +' Read file information with Win-API +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + '--------------------------------------------------------------------------------------- ' ' api/winapi/WinApiFileInfo.cls @@ -25,7 +25,7 @@ Attribute VB_Exposed = False ' '--------------------------------------------------------------------------------------- ' -' Code basiert auf http://support.microsoft.com/kb/509493/ +' Code based on http://support.microsoft.com/kb/509493/ ' Option Compare Text Option Explicit @@ -103,6 +103,31 @@ Private Type FILEINFOOUT ProductVersion As String End Type +'--------------------------------------------------------------------------------------- +' Function: GetFileVersion +'--------------------------------------------------------------------------------------- +' +' Determines the version of a file +' +' Parameters: +' FilePath - full path to the file +' +' Returns: +' Version identifier +' +' Remarks: +' Useful for reading versions from dll files +' +'-------------------------------------------------------------------------------------- +Public Function GetFileVersion(ByVal FilePath As String) As String + Dim VerInfo As FILEINFOOUT + If GetVersion(FilePath, VerInfo) Then + GetFileVersion = VerInfo.FileVersion + Else + GetFileVersion = vbNullString + End If +End Function + Private Function GetVersion(ByVal FilePath As String, _ ByRef GetFileInfo As FILEINFOOUT) As Boolean @@ -151,26 +176,3 @@ Private Function GetVersion(ByVal FilePath As String, _ GetVersion = True End Function - -'--------------------------------------------------------------------------------------- -' Function: GetFileVersion -'--------------------------------------------------------------------------------------- -'/** -' -' Ermittelt die Version aus einer Datei -' -' vollständiger Pfad zur Datei -' Versionskennung -' -' Nützlich zum Auslesen von Versionen aus dll-Dateien -' -'**/ -'--------------------------------------------------------------------------------------- -Public Function GetFileVersion(ByVal FilePath As String) As String - Dim VerInfo As FILEINFOOUT - If GetVersion(FilePath, VerInfo) Then - GetFileVersion = VerInfo.FileVersion - Else - GetFileVersion = vbNullString - End If -End Function diff --git a/access-add-in/source/codelib/api/winapi/WinApiImageTools.cls b/access-add-in/source/codelib/api/winapi/WinApiImageTools.cls index 6f2fa78..104481d 100644 --- a/access-add-in/source/codelib/api/winapi/WinApiImageTools.cls +++ b/access-add-in/source/codelib/api/winapi/WinApiImageTools.cls @@ -8,17 +8,16 @@ Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False '--------------------------------------------------------------------------------------- -' Class: WinApiImageTools +' Class: api.winapi.WinApiImageTools '--------------------------------------------------------------------------------------- -'/** -' -' WinAPI-Funktionen: Image & Co. -' -' -' Sammlung von API-Deklarationen, die oft benötigt werden -' -'\ingroup WinAPI -'**/ +' +' WinAPI functions: Image & Co. +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + '--------------------------------------------------------------------------------------- ' ' api/winapi/WinApiImageTools.cls @@ -72,20 +71,17 @@ Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" ( _ '--------------------------------------------------------------------------------------- ' Sub: SetFormIconFromFile '--------------------------------------------------------------------------------------- -'/** -' +' ' Spezielles Icon für ein Formular einstellen -' -' Referenz zum Access.Form -' Icon-Datei (vollständige Pfadangabe) -' ' -' -'**/ +' Parameters: +' FormRef - Reference to the Access.Form +' IconFilePath - Icon file (full path specification) +' '--------------------------------------------------------------------------------------- Public Sub SetFormIconFromFile(ByRef FormRef As Access.Form, ByVal IconFilePath As String) -On Error Resume Next ' ... Fehlermeldung würde bei dieser "unwichtigen" Funktion nur stören +On Error Resume Next ' ... Error message would only interfere with this "unimportant" function Const ICONPIXELSIZE As Long = 16 diff --git a/access-add-in/source/codelib/api/winapi/WinApiLayoutTools.cls b/access-add-in/source/codelib/api/winapi/WinApiLayoutTools.cls index 31aaeb5..ef80de9 100644 --- a/access-add-in/source/codelib/api/winapi/WinApiLayoutTools.cls +++ b/access-add-in/source/codelib/api/winapi/WinApiLayoutTools.cls @@ -8,16 +8,16 @@ Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False '--------------------------------------------------------------------------------------- -' Module: WinApiLayoutTools +' Class: api.winapi.WinApiLayoutTools '--------------------------------------------------------------------------------------- -'/** -' -' WinAPI-Funktionen zur Layoutgestaltung -' -' -' -'\ingroup WinAPI -'**/ +' +' WinAPI functions for layout design +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + '--------------------------------------------------------------------------------------- ' ' api/winapi/WinApiLayoutTools.cls @@ -101,26 +101,23 @@ Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal DC As Long, ByVal Inde '--------------------------------------------------------------------------------------- ' Sub: SetBackColor '--------------------------------------------------------------------------------------- -'/** -' -' Hintergrundfarbe eines Fensters einstellen -' -' Fenster-Handle -' Farbnummer -' -' -' -'**/ +' +' Set background color of a window +' +' Parameters: +' Hwnd - Window handle +' Color - Color number +' '--------------------------------------------------------------------------------------- Public Sub SetBackColor(ByVal Hwnd As LongPtr, ByVal Color As Long) Dim NewBrush As LongPtr - 'Brush erzeugen + 'Create Brush NewBrush = CreateSolidBrush(Color) - 'Brush zuweisen + 'Assign Brush SetClassLong Hwnd, GCL_HBRBACKGROUND, NewBrush - 'Fenster neuzeichnen (gesamtes Fenster inkl. Background) + 'Redraw window (entire window incl. background) RedrawWindow Hwnd, ByVal 0&, ByVal 0&, RDW_INVALIDATE Or RDW_ERASE End Sub @@ -128,16 +125,15 @@ End Sub '--------------------------------------------------------------------------------------- ' Function: TwipsPerPixelX '--------------------------------------------------------------------------------------- -'/** -' -' Breite eines Pixels in twips -' -' -' Single -' -' http://support.microsoft.com/kb/94927/de -' -'**/ +' +' Width of a pixel in twips +' +' Returns: +' Single +' +' Remarks: +' http://support.microsoft.com/kb/94927 +' '--------------------------------------------------------------------------------------- Public Function TwipsPerPixelX() As Single Dim DC As LongPtr @@ -149,15 +145,15 @@ End Function '--------------------------------------------------------------------------------------- ' Function: TwipsPerPixelY '--------------------------------------------------------------------------------------- -'/** -' -' Höhe eines Pixels in twips -' -' Single -' -' http://support.microsoft.com/kb/94927/de -' -'**/ +' +' Height of a pixel in twips +' +' Returns: +' Single +' +' Remarks: +' http://support.microsoft.com/kb/94927 +' '--------------------------------------------------------------------------------------- Public Function TwipsPerPixelY() As Single Dim DC As LongPtr @@ -169,15 +165,12 @@ End Function '--------------------------------------------------------------------------------------- ' Function: GetScrollbarWidth '--------------------------------------------------------------------------------------- -'/** -' -' Breite der Bildlaufleiste -' -' -' Single -' -' -'**/ +' +' Width of the scroll bar +' +' Returns: +' Single +' '--------------------------------------------------------------------------------------- Public Function GetScrollbarWidth() As Single GetScrollbarWidth = GetSystemMetrics(SM_CXVSCROLL) * TwipsPerPixelX @@ -186,16 +179,18 @@ End Function '--------------------------------------------------------------------------------------- ' Function: GetTwipsFromPixel '--------------------------------------------------------------------------------------- -'/** -' -' Rechnet Pixel in Twips um -' -' Anzahl der Pixel -' Long -' -' GetTwipsFromPixel = TwipsPerPixelX * pixel -' -'**/ +' +' Converts pixels to twips +' +' Parameters: +' Pixel - Number of pixels +' +' Returns: +' Long +' +' Remarks: +' GetTwipsFromPixel = TwipsPerPixelX * pixel +' '--------------------------------------------------------------------------------------- Public Function GetTwipsFromPixel(ByVal Pixel As Long) As Long GetTwipsFromPixel = TwipsPerPixelX * Pixel @@ -204,16 +199,18 @@ End Function '--------------------------------------------------------------------------------------- ' Function: GetPixelFromTwips '--------------------------------------------------------------------------------------- -'/** -' -' Rechnet twips in Pixel um -' -' Anzahl twips -' Long -' -' GetPixelFromTwips = twips / TwipsPerPixelX -' -'**/ +' +' Converts twips to pixels +' +' Parameters: +' Twips - Number of twips +' +' Returns: +' Long +' +' Remarks: +' GetPixelFromTwips = Twips / TwipsPerPixelX +' '--------------------------------------------------------------------------------------- Public Function GetPixelFromTwips(ByVal Twips As Long) As Long GetPixelFromTwips = Twips / TwipsPerPixelX diff --git a/access-add-in/source/codelib/api/winapi/WinApiShellTools.cls b/access-add-in/source/codelib/api/winapi/WinApiShellTools.cls index 19fe275..94b0839 100644 --- a/access-add-in/source/codelib/api/winapi/WinApiShellTools.cls +++ b/access-add-in/source/codelib/api/winapi/WinApiShellTools.cls @@ -8,17 +8,16 @@ Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False '--------------------------------------------------------------------------------------- -' Class: WinApiShellTools +' Class: api.winapi.WinApiShellTools '--------------------------------------------------------------------------------------- -'/** -' -' WinAPI-Funktionen: ShellExecuteA & Co. -' -' -' Sammlung von API-Deklarationen, die oft benötigt werden -' -'\ingroup WinAPI -'**/ +' +' WinAPI functions: ShellExecuteA & Co. +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + '--------------------------------------------------------------------------------------- ' ' api/winapi/WinApiShellTools.cls @@ -126,22 +125,23 @@ Private Declare Sub Sleep Lib "kernel32" (ByVal DwMilliseconds As Long) '--------------------------------------------------------------------------------------- -' Kapselungen +' Encapsulations '--------------------------------------------------------------------------------------- '--------------------------------------------------------------------------------------- -' Function: ShellExecuteOpenFile (Josef Pötzl, 2010-04-19) +' Function: ShellExecuteOpenFile '--------------------------------------------------------------------------------------- -'/** -' -' Datei mit ShellExecute öffnen -' -' vollständiger Dateiname inkl. Verzeichnis -' "open", "print", ... -' Boolean -' -' -'**/ +' +' Open file with ShellExecute +' +' Parameters: +' FilePath - full file name (incl. directory) +' ApiOperation - (optional) "open", "print", ..., Default: vbNullString +' ShowCmd - (optional) VbAppWinStyle, Default: vbNormalFocus +' +' Returns: +' Boolean +' '--------------------------------------------------------------------------------------- Public Function Execute(ByVal FilePath As String, _ Optional ByVal ApiOperation As String = vbNullString, _ @@ -160,14 +160,12 @@ Public Function Execute(ByVal FilePath As String, _ End If If Ret = SE_ERR_NOTFOUND Then - 'Datei nicht gefunden - MsgBox "Datei nicht gefunden" & vbNewLine & vbNewLine & _ + MsgBox "File not found" & vbNewLine & vbNewLine & _ FilePath Execute = False Exit Function ElseIf Ret = SE_ERR_NOASSOC Then - 'Wenn die Dateierweiterung noch nicht bekannt ist... - 'wird der "Öffnen mit..."-Dialog angezeigt. + 'If the file extension is not yet known, the "Open with..." dialog is displayed. Directory = Space$(260) Ret = GetSystemDirectory(Directory, Len(Directory)) Directory = Left$(Directory, Ret) @@ -182,15 +180,15 @@ End Function '--------------------------------------------------------------------------------------- ' Function: ExecuteAsAdmin '--------------------------------------------------------------------------------------- -'/** -' -' Befehl mit erweiterter, administrativer Berechtigung ausführen -' -' vollständiger Dateiname inkl. Verzeichnis -' Boolean -' -' -'**/ +' +' Execute command with extended administrative privilege +' +' Parameters: +' File - full file name incl. directory +' +' Returns: +' Boolean +' '--------------------------------------------------------------------------------------- Public Function ExecuteAsAdmin(ByVal File As String) As Boolean ExecuteAsAdmin = Me.Execute(File, "runas") @@ -199,17 +197,17 @@ End Function '--------------------------------------------------------------------------------------- ' Function: ShellExecuteSendMail '--------------------------------------------------------------------------------------- -'/** -' -' Email mit Standard-Programm versenden -' -' Empfänger-Adresse -' Betreff-Zeile -' Email-Text -' Boolean -' -' -'**/ +' +' Send email with standard program +' +' Parameters: +' SendTo - Recipient address +' Subject - Subject line +' Body - Email text +' +' Returns: +' Boolean +' '--------------------------------------------------------------------------------------- Public Function ShellExecuteSendMail(ByVal SendTo As String, _ ByVal Subject As String, _ @@ -239,28 +237,28 @@ Public Function ShellExecuteSendMail(ByVal SendTo As String, _ lpFile = "mailto:" & SendTo End If - - Ret = ShellExecuteA(GetDesktopWindow(), "open", lpFile, vbNullString, vbNullString, vbNormalFocus) ShellExecuteSendMail = (Ret <> 0) End Function '--------------------------------------------------------------------------------------- -' Function: LaunchAppSynchronous (Josef Pötzl, 2010-04-19) +' Function: LaunchAppSynchronous '--------------------------------------------------------------------------------------- -'/** -' +' ' Anwnedung Synchron ausführen -' -' Ausführbare Datei -' Startparameter der Anwendung -' Fenstermodus -' Boolean -' -' Code hält so lange an, bis die gestartete Anwendung beendet wurde. -' -'**/ +' +' Parameters: +' ExecutablePathAndName - Executable file +' Param - (optional) Start parameters of the application +' ShowCommand - (optional) window mode, Default: vbNormalFocus +' +' Returns: +' Boolean +' +' Remarks: +' Code hält so lange an, bis die gestartete Anwendung beendet wurde. +' '--------------------------------------------------------------------------------------- Public Function LaunchAppSynchronous(ByVal ExecutablePathAndName As String, _ Optional ByVal Param As String = vbNullString, _ @@ -286,7 +284,6 @@ Public Function LaunchAppSynchronous(ByVal ExecutablePathAndName As String, _ 'Launch the application by creating a new process Response = CreateProcess(vbNullString, ExecutablePathAndName & " " & Param, 0, 0, True, NORMAL_PRIORITY_CLASS, ByVal 0&, vbNullString, StartUpInf, ProcInfo) - If Response Then 'Wait for the application to terminate before moving on Call WaitForTermination(ProcInfo) diff --git a/access-add-in/source/codelib/api/winapi/WinApiShortcutMenu.cls b/access-add-in/source/codelib/api/winapi/WinApiShortcutMenu.cls index a4cd15a..37e13e9 100644 --- a/access-add-in/source/codelib/api/winapi/WinApiShortcutMenu.cls +++ b/access-add-in/source/codelib/api/winapi/WinApiShortcutMenu.cls @@ -9,19 +9,23 @@ Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Attribute VB_Description = "ShortcutMenu über Win-API" '--------------------------------------------------------------------------------------- -' Class Module: WinApiShortcutMenu +' Class: api.winapi.WinApiShortcutMenu '--------------------------------------------------------------------------------------- -'/** -' -' ShortcutMenu über Win-API -' -' -' -'\ingroup WinAPI ' -' @todo Code aufräumen und Doxygen-Doku erstellen +' ShortcutMenu via Win API +' +' Author: +' Josef Poetzl +' +' @todo Clean up code and create doc +' +' Remarks: +'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +' | Adapted variant from API example by Jörg Ostendorp of AEK10 +'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ' -'**/ +'--------------------------------------------------------------------------------------- + '--------------------------------------------------------------------------------------- ' ' api/winapi/WinApiShortcutMenu.cls @@ -34,13 +38,9 @@ Attribute VB_Description = "ShortcutMenu Option Compare Text Option Explicit -'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -'Angepasste Variante aus API-Beispiel von Jörg Ostendorp der AEK10 -'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - Private Type POINTAPI - x As Long - y As Long + X As Long + Y As Long End Type Private Type RECT @@ -52,7 +52,7 @@ End Type #If VBA7 Then -Private m_Helper As LongPtr 'Hilfsfenster-Handle +Private m_Helper As LongPtr 'Auxiliary window handle Private Type APIMSG Hwnd As LongPtr @@ -63,7 +63,7 @@ Private Type APIMSG pt As POINTAPI End Type -'Hilfsfenster +'Auxiliary window Private Declare PtrSafe Function CreateWindowEx _ Lib "user32.dll" _ Alias "CreateWindowExA" ( _ @@ -71,8 +71,8 @@ Private Declare PtrSafe Function CreateWindowEx _ ByVal lpClassname As String, _ ByVal lpWindowName As String, _ ByVal dwStyle As Long, _ - ByVal x As Long, _ - ByVal y As Long, _ + ByVal X As Long, _ + ByVal Y As Long, _ ByVal nWidth As Long, _ ByVal nHeight As Long, _ ByVal hwndParent As LongPtr, _ @@ -80,7 +80,7 @@ Private Declare PtrSafe Function CreateWindowEx _ ByVal hInstance As LongPtr, _ ByRef lpParam As Any) As Long -'Menü-Standardfunktionen +'Standard menu functions Private Declare PtrSafe Function CreatePopupMenu _ Lib "user32.dll" () As Long @@ -97,8 +97,8 @@ Private Declare PtrSafe Function TrackPopupMenu _ Lib "user32.dll" ( _ ByVal hMenu As LongPtr, _ ByVal wFlags As Long, _ - ByVal x As Long, _ - ByVal y As Long, _ + ByVal X As Long, _ + ByVal Y As Long, _ ByVal nReserved As Long, _ ByVal Hwnd As LongPtr, _ lprc As Any _ @@ -109,7 +109,7 @@ Private Declare PtrSafe Function DestroyMenu _ ByVal hMenu As LongPtr _ ) As Long -'Message-Loop +'Message Loop Private Declare PtrSafe Function GetMessage _ Lib "user32.dll" _ Alias "GetMessageA" ( _ @@ -143,7 +143,7 @@ Private Declare PtrSafe Function SetMenuDefaultItem _ #Else -Private m_Helper As Long 'Hilfsfenster-Handle +Private m_Helper As Long 'Auxiliary window handle Private Type APIMSG Hwnd As Long @@ -154,7 +154,7 @@ Private Type APIMSG pt As POINTAPI End Type -'Hilfsfenster +'Auxiliary window Private Declare Function CreateWindowEx _ Lib "user32.dll" _ Alias "CreateWindowExA" ( _ @@ -162,8 +162,8 @@ Private Declare Function CreateWindowEx _ ByVal lpClassname As String, _ ByVal lpWindowName As String, _ ByVal dwStyle As Long, _ - ByVal x As Long, _ - ByVal y As Long, _ + ByVal X As Long, _ + ByVal Y As Long, _ ByVal nWidth As Long, _ ByVal nHeight As Long, _ ByVal hwndParent As Long, _ @@ -171,7 +171,7 @@ Private Declare Function CreateWindowEx _ ByVal hInstance As Long, _ ByRef lpParam As Any) As Long -'Menü-Standardfunktionen +'Standard menu functions Private Declare Function CreatePopupMenu _ Lib "user32.dll" () As Long @@ -188,8 +188,8 @@ Private Declare Function TrackPopupMenu _ Lib "user32.dll" ( _ ByVal hMenu As Long, _ ByVal wFlags As Long, _ - ByVal x As Long, _ - ByVal y As Long, _ + ByVal X As Long, _ + ByVal Y As Long, _ ByVal nReserved As Long, _ ByVal Hwnd As Long, _ lprc As Any _ @@ -200,7 +200,7 @@ Private Declare Function DestroyMenu _ ByVal hMenu As Long _ ) As Long -'Message-Loop +'Message Loop Private Declare Function GetMessage _ Lib "user32.dll" _ Alias "GetMessageA" ( _ @@ -238,7 +238,7 @@ Private Declare Function SetMenuDefaultItem _ Private Const WM_COMMAND As Long = &H111 Private Const WM_MOUSELEAVE As Long = &H2A3 -'Menü- bzw. Item-Styles +'Menu or item styles Public Enum MenuItemStyle MF_SEPARATOR = &H800& @@ -252,14 +252,14 @@ Public Enum MenuItemStyle MF_CHECKED = &H8& End Enum -'Menü-Ausrichtung +'Menu alignment Private Const TPM_BOTTOMALIGN As Long = &H20& 'Private Const TPM_TOPALIGN As Long = &H0& -'Hilfsfenster +'Auxiliary window Private Const WS_CHILD As Long = &H40000000 -'---- Ergänzung +'---- additions: Private Type WinAPIMenuHandlerItem ItemNumber As Long @@ -377,17 +377,15 @@ End Property '--------------------------------------------------------------------------------------- ' Sub: AddMenuItem '--------------------------------------------------------------------------------------- -'/** -' -' Menü-Eintrag erstellen -' -' Nummer des Menüeintrags -' Text des Menüeintrags -' Art des Menüeintrags -' Nummer des zugeordneten Untermenüs -' -' -'**/ +' +' Create menu item +' +' Parameters: +' MenuItemNumber - Number of the menu item +' ItemText - Menu item text +' ItemType - Menu item type +' SubMenu - Number of the assigned submenu +' '--------------------------------------------------------------------------------------- Public Sub AddMenuItem(ByVal MenuItemNumber As Long, ByVal ItemText As String, _ Optional ByVal ItemType As MenuItemStyle = MF_STRING, _ @@ -410,18 +408,18 @@ End Sub '--------------------------------------------------------------------------------------- ' Function: OpenMenu '--------------------------------------------------------------------------------------- -'/** -' +' ' Öffnet das Popup-Menü -' -' gewünschte X-Positon .. kann entfallen, wenn Control angegeben wurde -' gewünschte Y-Positon .. kann entfallen, wenn Control angegeben wurde -' Nummer des ausgewählten Menüeintrags -' -' -'**/ +' +' Parameters: +' X - desired X position ... can be omitted if Control was specified +' X - desired Y-position ... can be omitted if Control was specified +' +' Returns: +' Long - Number of the selected menu item +' '--------------------------------------------------------------------------------------- -Public Function OpenMenu(Optional ByVal x As Single = 0, Optional ByVal y As Single = 0) As Long +Public Function OpenMenu(Optional ByVal X As Single = 0, Optional ByVal Y As Single = 0) As Long #If VBA7 Then Dim MenuHwnd As LongPtr @@ -437,19 +435,19 @@ Public Function OpenMenu(Optional ByVal x As Single = 0, Optional ByVal y As Sin Dim RcHelper As RECT Dim ButtonLeft As Long Dim ButtonTop As Long - Dim Xpos As Long - Dim Ypos As Long + Dim XPos As Long + Dim YPos As Long Dim ParentObj As Object Dim AccFormRect As RECT - 'Sonst wird bei ENTER nix angezeigt: + 'Otherwise, nothing is displayed when ENTER is pressed: DoEvents - 'Leeres Menü erstellen + 'Create empty menu MenuHwnd = CreatePopupMenu - 'Einträge hinzufügen + 'Add entries Dim i As Long For i = 1 To m_ItemCnt @@ -474,24 +472,24 @@ Public Function OpenMenu(Optional ByVal x As Single = 0, Optional ByVal y As Sin Next i - 'Position ermitteln - '- Hilfsfenster (~Sektionsfenster) absolut + 'Determine position + '- Auxiliary window (~section window) absolute GetWindowRect m_Helper, RcHelper If m_MenuControl Is Nothing Then GetWindowRect m_AccessForm.Hwnd, AccFormRect - ButtonLeft = LayoutTools.GetPixelFromTwips(x) + AccFormRect.Left - ButtonTop = LayoutTools.GetPixelFromTwips(y) + AccFormRect.Top + ButtonLeft = LayoutTools.GetPixelFromTwips(X) + AccFormRect.Left + ButtonTop = LayoutTools.GetPixelFromTwips(Y) + AccFormRect.Top Else - '- Buttom relativ zum Sektionsfenster - ButtonLeft = LayoutTools.GetPixelFromTwips(m_MenuControl.Left) + LayoutTools.GetPixelFromTwips(x) - ButtonTop = LayoutTools.GetPixelFromTwips(m_MenuControl.Top) + LayoutTools.GetPixelFromTwips(y) + '- Buttom relative to the section window + ButtonLeft = LayoutTools.GetPixelFromTwips(m_MenuControl.Left) + LayoutTools.GetPixelFromTwips(X) + ButtonTop = LayoutTools.GetPixelFromTwips(m_MenuControl.Top) + LayoutTools.GetPixelFromTwips(Y) End If - '- Miteinander verrechnen - Xpos = RcHelper.Left + ButtonLeft - 1 - Ypos = RcHelper.Top + ButtonTop + '- calc with each other + XPos = RcHelper.Left + ButtonLeft - 1 + YPos = RcHelper.Top + ButtonTop - 'Menü anzeigen + 'Show menu If m_MenuControl Is Nothing Then Set ParentObj = m_AccessForm @@ -502,10 +500,10 @@ Public Function OpenMenu(Optional ByVal x As Single = 0, Optional ByVal y As Sin End If End If - TrackPopupMenu MenuHwnd, TPM_BOTTOMALIGN, Xpos, Ypos, _ + TrackPopupMenu MenuHwnd, TPM_BOTTOMALIGN, XPos, YPos, _ ByVal 0&, ParentObj.Hwnd, ByVal 0& - 'Message-Loop (Obacht: für normale Formulare Application.hWndAccessApp, für POPUPS Me.hwnd) + 'Message-Loop (Attention: for normal forms Application.hWndAccessApp, for POPUPS Form.Hwnd) If m_AccessForm.PopUp = True Then Hwnd = m_AccessForm.Hwnd @@ -514,13 +512,13 @@ Public Function OpenMenu(Optional ByVal x As Single = 0, Optional ByVal y As Sin End If Dim RepeatGetMessage As Boolean - Do 'Sicherheitsschliefe, falls es Probleme mit Windows-Message gibt. (WM_MOUSELEAVE) + Do ' Security sleep in case there are problems with windows message. (WM_MOUSELEAVE] RepeatGetMessage = False GetMessage Message, Hwnd, ByVal 0&, ByVal 0& TranslateMessage Message DispatchMessage Message - 'Message auswerten + 'Evaluate message If Message.Message = WM_COMMAND Then OpenMenu = Message.wParam ElseIf Message.Message = WM_MOUSELEAVE Then @@ -530,7 +528,7 @@ Public Function OpenMenu(Optional ByVal x As Single = 0, Optional ByVal y As Sin End If Loop While RepeatGetMessage - 'Menü zerstören + 'Destroy menu DestroyMenu MenuHwnd End Function diff --git a/access-add-in/source/codelib/api/winapi/WinApiTools.cls b/access-add-in/source/codelib/api/winapi/WinApiTools.cls index 1ad99d8..264e636 100644 --- a/access-add-in/source/codelib/api/winapi/WinApiTools.cls +++ b/access-add-in/source/codelib/api/winapi/WinApiTools.cls @@ -8,17 +8,17 @@ Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False '--------------------------------------------------------------------------------------- -' Klassenmodul: WinApiTools -'--------------------------------------------------------------------------------------- -'/** -' -' Sammlung von WinAPI-Tools -' -' -' -'**/ +' Class: api.winapi.WinApiTools '--------------------------------------------------------------------------------------- ' +' Factory for WinAPI classes +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + +'--------------------------------------------------------------------------------------- ' ' api/winapi/WinApiTools.cls ' _codelib/license.bas diff --git a/access-add-in/source/codelib/api/winapi/WinApiToolsFactory.bas b/access-add-in/source/codelib/api/winapi/WinApiToolsFactory.bas index 4506920..b18429a 100644 --- a/access-add-in/source/codelib/api/winapi/WinApiToolsFactory.bas +++ b/access-add-in/source/codelib/api/winapi/WinApiToolsFactory.bas @@ -1,15 +1,16 @@ Attribute VB_Name = "WinApiToolsFactory" Attribute VB_Description = "Gebräuchliche WinAPI-Funktionen" '--------------------------------------------------------------------------------------- -' Modul: WinApiToolsFactory +' Package: api.winapi.WinApiToolsFactory '--------------------------------------------------------------------------------------- -'/** -' -' Erzeugt Instanz von WinApiTools -' -' -' -'**/ +' +' Creates instance of WinApiTools +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + '--------------------------------------------------------------------------------------- ' ' api/winapi/WinApiToolsFactory.bas diff --git a/access-add-in/source/codelib/api/winapi/WinApiWindowTools.cls b/access-add-in/source/codelib/api/winapi/WinApiWindowTools.cls index dccb6e7..084dd7e 100644 --- a/access-add-in/source/codelib/api/winapi/WinApiWindowTools.cls +++ b/access-add-in/source/codelib/api/winapi/WinApiWindowTools.cls @@ -8,16 +8,22 @@ Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False '--------------------------------------------------------------------------------------- -' Module: WinApiWindowTools +' Class: api.winapi.WinApiWindowTools '--------------------------------------------------------------------------------------- -'/** -' -' WinAPI-Funktionen: Window Handle & Co. -' -' -' -' \ingroup WinAPI -'**/ +' +' WinAPI functions: Window Handle & Co. +' +' Author: +' Josef Poetzl +' +' Source info: +'--------------------------------------------------------------------------------------- +'| The procedures GetMDI, GetHeaderSection, GetDetailSection, GetFooterSection and GetControl +'| are taken from the AEK10 lecture by Jörg Ostendorp +'--------------------------------------------------------------------------------------- +' +'--------------------------------------------------------------------------------------- + '--------------------------------------------------------------------------------------- ' ' api/winapi/WinApiWindowTools.cls @@ -25,17 +31,12 @@ Attribute VB_Exposed = False ' '--------------------------------------------------------------------------------------- ' -' Die Prozeduren (GetMDI, GetHeaderSection, GetDetailSection, GetFooterSection und GetControl -' stammen aus dem AEK10-Vortrag von Jörg Ostendorp -' -'---------------------------------------------------------------------------------------- -' Option Compare Text Option Explicit Private Type POINTAPI - x As Long - y As Long + X As Long + Y As Long End Type Private Declare PtrSafe Function ClientToScreen Lib "user32.dll" ( _ @@ -53,38 +54,36 @@ Private Declare PtrSafe Function FindWindowEx Lib "user32.dll" Alias "FindWindow '--------------------------------------------------------------------------------------- ' Function: GetMDI '--------------------------------------------------------------------------------------- -'/** -' -' Ermittelt den Handle des MDI-Client-Fensters. -' -' Handle (Long) -' -' -'**/ +' +' Determines the handle of the MDI client window +' +' Returns: +' Handle (LongPtr) +' '--------------------------------------------------------------------------------------- Public Function GetMDI() As LongPtr Dim h As LongPtr h = Application.hWndAccessApp - 'Erstes (und einziges) "MDIClient"-Kindfenster des Applikationsfensters suchen + 'Find the first (and only) "MDIClient" child window of the application window. GetMDI = FindWindowEx(h, 0&, "MDIClient", vbNullString) End Function '--------------------------------------------------------------------------------------- ' Function: GetHeaderSection '--------------------------------------------------------------------------------------- -'/** -' -' Ermittelt den Handle für den Kopfbereich eines Formulares -' -' Handle des Formulars (Form.Hwnd) -' Long -' -' -'**/ +' +' Determines the handle for the header area of a form +' +' Parameters: +' Hwnd - Handle of the form (Form.Hwnd) +' +' Returns: +' LongPtr +' '--------------------------------------------------------------------------------------- Public Function GetHeaderSection(ByVal Hwnd As LongPtr) As LongPtr Dim h As LongPtr - 'Erstes "OFormsub"-Kindfenster des Formulares (fhwnd) ermitteln + 'Determine first "OFormsub" child window of the form (fhwnd) h = FindWindowEx(Hwnd, 0&, "OformSub", vbNullString) GetHeaderSection = h End Function @@ -92,20 +91,19 @@ End Function '--------------------------------------------------------------------------------------- ' Function: GetDetailSection '--------------------------------------------------------------------------------------- -'/** -' -' Ermittelt den Handle für den Detailbereich eines Formulares -' -' Handle des Formulars (Form.Hwnd) -' Long -' -' -'**/ +' +' Determines the handle for the detail area of a form +' +' Parameters: +' Hwnd - Handle of the form (Form.Hwnd) +' +' Returns: +' LongPtr +' '--------------------------------------------------------------------------------------- Public Function GetDetailSection(ByVal Hwnd As LongPtr) As LongPtr Dim h As LongPtr - 'Erstes "OFormsub"-Kindfenster des Formulares (fhwnd) ermitteln, beginnend - 'nach dem Kopfbereich + 'Determine first "OFormsub" child window of the form (fhwnd), starting after the header area. h = GetHeaderSection(Hwnd) h = FindWindowEx(Hwnd, h, "OformSub", vbNullString) GetDetailSection = h @@ -114,20 +112,19 @@ End Function '--------------------------------------------------------------------------------------- ' Function: GetFooterSection '--------------------------------------------------------------------------------------- -'/** -' -' Ermittelt den Handle für den Fußbereich eines Formulares -' -' Handle des Formulars (Form.Hwnd) -' Long -' -' -'**/ +' +' Determines the handle for the footer of a form +' +' Parameters: +' Hwnd - Handle of the form (Form.Hwnd) +' +' Returns: +' LongPtr +' '--------------------------------------------------------------------------------------- Public Function GetFooterSection(ByVal Hwnd As Long) As LongPtr Dim h As LongPtr - 'Erstes "OFormsub"-Kindfenster des Formulares (fhwnd) ermitteln, beginnend - 'nach dem Detailbereich + 'Determine first "OFormsub" child window of the form (fhwnd), starting after the detail area. h = GetDetailSection(Hwnd) h = FindWindowEx(Hwnd, h, "OformSub", vbNullString) GetFooterSection = h @@ -136,30 +133,21 @@ End Function '--------------------------------------------------------------------------------------- ' Function: GetControl '--------------------------------------------------------------------------------------- -'/** -' -' Ermittelt den Handle eines beliebigen Controls -' -' Formular-Referenz -' Handle des Bereichs, auf dem sich das Control befindet (Header, Detail, Footer) -' Name der Fensterklasse des Controls -' Name des Controls -' Long -' -' -'**/ +' +' Determines the handle of any control +' +' Parameters: +' FormRef - Form reference +' Hwnd - Handle of the area on which the control is located (Header, Detail, Footer) +' ClassName - Name of the window class of the control +' ControlName - Name des Controls +' +' Returns: +' LongPtr +' '--------------------------------------------------------------------------------------- -Public Function GetControl(ByRef FrmRef As Access.Form, ByVal Hwnd As LongPtr, _ - ByVal className As String, ByVal ControlName As String) As LongPtr - - 'Ermittelt den Handle eines beliebigen Controls - - 'Parameter: - ' frm - Formular - ' Handle des Bereichs, auf dem sich das Control befindet (Header, Detail, Footer) - ' ControName - Name der Fensterklasse des Controls - ' ControlName - Name des Controls - +Public Function GetControl(ByRef FormRef As Access.Form, ByVal Hwnd As LongPtr, _ + ByVal ClassName As String, ByVal ControlName As String) As LongPtr 'Exitieren mehrere Controls der gleichen Klasse auf einem Formular, z.B. TabControls, besteht das Problem, daß 'deren Reihenfolge nicht definiert ist (anders also als bei den Sektionsfenstern) @@ -182,16 +170,16 @@ On Error Resume Next Do 'Erstes (h=0)/nächstes (h<>0) Control auf dem Sektionsfenster ermitteln - h = FindWindowEx(Hwnd, h, className, vbNullString) + h = FindWindowEx(Hwnd, h, ClassName, vbNullString) 'Bildschirmkoordinaten dieses Controls ermitteln 'dafür die Punktkoordinaten aus dem letzten Durchlauf zurücksetzen, sonst wird addiert! - pt.x = 0 - pt.y = 0 + pt.X = 0 + pt.Y = 0 ClientToScreen h, pt 'Objekt bei den Koordinaten ermitteln - Set obj = FrmRef.accHitTest(pt.x, pt.y) + Set obj = FormRef.accHitTest(pt.X, pt.Y) 'Wenn Objektname = Tabname Ausstieg aus der Schleife If obj.Name = ControlName Then diff --git a/access-add-in/source/codelib/base/ApplicationHandler.cls b/access-add-in/source/codelib/base/ApplicationHandler.cls index c755a4e..85b4446 100644 --- a/access-add-in/source/codelib/base/ApplicationHandler.cls +++ b/access-add-in/source/codelib/base/ApplicationHandler.cls @@ -9,16 +9,16 @@ Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Attribute VB_Description = "Hauptsteuerung der Anwendung" '--------------------------------------------------------------------------------------- -' Klassenmodul: ApplicationHandler (Josef Pötzl, 2009-12-11) +' Class: base.ApplicationHandler '--------------------------------------------------------------------------------------- -'/** -' -' Hauptsteuerung der Anwendung -' -' -' -'\ingroup base -'**/ +' +' Main control of the application +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + '--------------------------------------------------------------------------------------- ' ' base/ApplicationHandler.cls @@ -31,10 +31,10 @@ Option Compare Text Option Explicit Public Enum ApplicationHandlerResumeModes - ' 0 ... keine Antwort - AppResumeMode_Completed = 1 ' Anforderung wurde erfolgreich abgearbeitet - AppResumeMode_Error = 2 ' Event wurde angenommen, aber es traten Fehler auf - AppResumeMode_Cancel = 4 ' Event wurde angenommen, aber Weiterverabeitung soll gestoppt werden + [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 @@ -44,17 +44,18 @@ Public Enum ApplicationHandlerLogType End Enum -' Integrierte Erweiterungen +' Integrated extensions Private Const EXTENSION_KEY_APPFILE As String = "AppFile" -' Fehlerkennungen +' Error codes Private Const ERR_CLASS_ID As Long = 1000 + Public Enum ApplicationHandlerErrors AppErr_EventInterfaceMissing = vbObjectError + ERR_CLASS_ID + 1 End Enum -' API-Funktionen +' API definitions Private Const GCL_HBRBACKGROUND As Long = -10 Private Const RDW_INVALIDATE As Long = &H1 Private Const RDW_ERASE As Long = &H4 @@ -96,7 +97,7 @@ Private Declare Function GetSysColor Lib "user32" (ByVal Index As Long) As Long #End If -' Hilfskonstanten +' Auxiliary constants Private Const LOG_FILE As String = "log.txt" Private Const DBPROPNAME_APPTITLE As String = "AppTitle" @@ -106,18 +107,17 @@ Private Const DBPROPNAME_STARTUPFORM As String = "StartUpForm" Private Const DBPROPNAME_STARTUPMENUBAR As String = "StartUpMenuBar" -'Hilfsvariablen -Private m_AppDb As DAO.Database ' Ersatz für CurrentDb bzw. CodeDb, siehe Prop: AppDb +'Auxiliary variables +Private m_AppDb As DAO.Database ' Replacement for CurrentDb or CodeDb, see Prop: AppDb -Private m_ApplicationName As String ' Zwischenspeicher für Anwendungsnamen (kurz) -Private m_ApplicationFullName As String ' Zwischenspeicher für Anwendungsnamen (lang) - -Private m_APPLICATIONVERSION As String ' anzuzeigende Versionnummer +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 ' Standardverzeichnis für Dateiexplorer +Private m_PublicPath As String ' Default directory for file explorer -Private m_ApplicationStartFormName As String ' Formular das in Start-Methode geöffnet wird +Private m_ApplicationStartFormName As String ' Form that is opened in Start method Private m_CustomMDIBackgroundColor As Long @@ -165,16 +165,15 @@ Public Event BeforeStartApplication( _ Public Event AfterStartApplication( _ ByRef ResumeMode As ApplicationHandlerResumeModes, ByRef ResumeMessage As Variant) -'Tracing-Schnittstelle +'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 '--------------------------------------------------------------------------------------- -' Dispose-Ablauf +' Disposable support '--------------------------------------------------------------------------------------- Private m_Disposed As Boolean Private Sub Class_Terminate() @@ -210,18 +209,18 @@ On Error Resume Next End Sub '--------------------------------------------------------------------------------------- -' Function: Start (Josef Pötzl, 2009-12-15) +' Function: Start '--------------------------------------------------------------------------------------- -'/** -' -' Start der Anwendung -' -' Boolean -' -' Nicht Verwechseln mit Initialisierung von ApplicationHandler \n -' Diese Prozedur löst die Startroutine für den Anwender aus. -' -'**/ +' +' 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 @@ -229,28 +228,28 @@ Public Function Start(Optional ByRef ResumeMessage As Variant) As Boolean Dim EventResumeMode As ApplicationHandlerResumeModes Dim EventResumeMessage As Variant - 'Evente-Schnittstelle für Anwendungsstart - ' ... ermöglicht z. B. das Durchführen eines Login-Vorgangs + '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 - 'Start abbrechen + 'Cancel start ResumeMessage = EventResumeMessage Start = False Exit Function Case ApplicationHandlerResumeModes.AppResumeMode_Completed - 'Startprozedur wurde von Erweiterung übernommen + 'Start procedure was taken over from extension Start = EventResumeMessage Exit Function Case ApplicationHandlerResumeModes.AppResumeMode_Error - 'Mit Fehlermeldung abbrechen + 'Cancel with error message Err.Raise vbObjectError, "BeforeStartApplication", EventResumeMessage Exit Function Case Else - 'weitermachen + 'continue End Select - 'Update prüfen + 'Check update If CheckVersionUpdate Then If Me.UpdateApplication Then Start = False @@ -259,18 +258,18 @@ Public Function Start(Optional ByRef ResumeMessage As Variant) As Boolean End If End If - 'Evente-Schnittstelle für Startformular - '... ermöglich das Ändern des Startformulars durch ERweiterungen - ' z. B. falls ein benutzerspezifisches Formulare geöffnet werden soll + '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 - 'Startform nicht öffnen + 'Do not open startup form CurrentStartFormName = vbNullString Case ApplicationHandlerResumeModes.AppResumeMode_Completed - 'Name des StartFormulars wurde übertragen + 'Name of the StartForm was transferred CurrentStartFormName = Nz(EventResumeMessage, vbNullString) Case Else CurrentStartFormName = Me.ApplicationStartFormName @@ -280,7 +279,7 @@ Public Function Start(Optional ByRef ResumeMessage As Variant) As Boolean DoCmd.OpenForm CurrentStartFormName End If - 'Benachrichtigung über erfolgten Anwendungsstart + 'Notification about successful application start EventResumeMode = 0 EventResumeMessage = Empty RaiseEvent AfterStartApplication(EventResumeMode, EventResumeMessage) @@ -293,18 +292,15 @@ End Function '--------------------------------------------------------------------------------------- ' Property: ApplicationName '--------------------------------------------------------------------------------------- -'/** -' -' Name der aktuellen Anwendung -' -' String -' -' Reihenfolge der Namensermittlung: -' 1. über gesetzten Wert -' 2. aus Titel-Eigenschaft mit CurrentDb.Properties("AppTitle") -' 3. aus Dateinamen mit CurrentDb.Name -' -'**/ +' +' 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 @@ -318,16 +314,6 @@ Public Property Get ApplicationName() As String ApplicationName = m_ApplicationName End Property -'--------------------------------------------------------------------------------------- -' Property: ApplicationName -'--------------------------------------------------------------------------------------- -'/** -' -' Name der aktuellen Anwendung einstellen -' -' Anwendungsname -'**/ -'--------------------------------------------------------------------------------------- Public Property Let ApplicationName(ByVal AppName As String) m_ApplicationName = AppName End Property @@ -336,17 +322,14 @@ End Property '--------------------------------------------------------------------------------------- ' Property: ApplicationFullName '--------------------------------------------------------------------------------------- -'/** -' -' Vollständiger Name der aktuellen Anwendung -' -' String -' -' Reihenfolge der Namensermittlung: -' 1. über gesetzten Wert -' 2. über ApplicationName -' -'**/ +' +' 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 @@ -355,16 +338,6 @@ Public Property Get ApplicationFullName() As String ApplicationFullName = m_ApplicationFullName End Property -'--------------------------------------------------------------------------------------- -' Property: ApplicationFullName -'--------------------------------------------------------------------------------------- -'/** -' -' Name der aktuellen Anwendung einstellen -' -' Anwendungsname -'**/ -'--------------------------------------------------------------------------------------- Public Property Let ApplicationFullName(ByVal AppName As String) m_ApplicationFullName = AppName End Property @@ -372,17 +345,9 @@ End Property '--------------------------------------------------------------------------------------- ' Property: ApplicationVersion '--------------------------------------------------------------------------------------- -'/** -' -' Vollständiger Name der aktuellen Anwendung -' -' String -' -' Reihenfolge der Namensermittlung: -' 1. über gesetzten Wert -' 2. über ApplicationName -' -'**/ +' +' Application version +' '--------------------------------------------------------------------------------------- Public Property Get Version() As String @@ -397,16 +362,6 @@ Public Property Get Version() As String End Property -'--------------------------------------------------------------------------------------- -' Property: ApplicationFullName -'--------------------------------------------------------------------------------------- -'/** -' -' Name der aktuellen Anwendung einstellen -' -' Anwendungsname -'**/ -'--------------------------------------------------------------------------------------- Public Property Let Version(ByVal AppVersion As String) m_APPLICATIONVERSION = AppVersion End Property @@ -414,13 +369,9 @@ End Property '--------------------------------------------------------------------------------------- ' Property: ApplicationStartForm '--------------------------------------------------------------------------------------- -'/** -' -' Formular, das in der Methode Start geöffnet wird -' -' -' -'**/ +' +' Form opened in the method +' '--------------------------------------------------------------------------------------- Public Property Get ApplicationStartFormName() As String If StrPtr(m_ApplicationStartFormName) = 0 Then ' ... aus Properties lesen? @@ -429,33 +380,16 @@ Public Property Get ApplicationStartFormName() As String ApplicationStartFormName = m_ApplicationStartFormName End Property -'--------------------------------------------------------------------------------------- -' Property: ApplicationStartForm -'--------------------------------------------------------------------------------------- -'/** -' -' Formular, das in der Methode Start geöffnet wird -' -' -' -'**/ -'--------------------------------------------------------------------------------------- Public Property Let ApplicationStartFormName(ByVal FormName As String) m_ApplicationStartFormName = FormName End Property - '--------------------------------------------------------------------------------------- -' Property: AppDb (Josef Pötzl, 2009-12-13) +' Property: AppDb '--------------------------------------------------------------------------------------- -'/** -' -' Ersatz für CurrentDb bzw. CodeDb (Standard: CodeDb) -' -' zugewiesene DAO.Database-Instanz -' -' -'**/ +' +' Replacement for CurrentDb or CodeDb (default: CodeDb). +' '--------------------------------------------------------------------------------------- Public Property Get AppDb() As DAO.Database If m_AppDb Is Nothing Then @@ -616,7 +550,7 @@ Public Sub WriteLog(ByVal Msg As String, _ RaiseEvent NewAppLog(LogType, Msg, Args, ResumeMode, EventResumeMessage) If ResumeMode = 0 And (WriteToFileIfNoEventResponse Or WriteLogToFileIfNoEventResponse Or LogType = AppLogType_Error) Then - 'niemand hat reagiert bzw. einen Abbruch gemeldet => WriteApplicationLogEntry + 'no one has reacted or reported an abort => WriteApplicationLogEntry Msg = Now() & ": " & Msg If Len(LogType) > 0 Then Msg = "(" & GetLogTypeString(LogType) & ") " & Msg @@ -637,59 +571,31 @@ Private Function GetLogTypeString(Optional ByRef LogType As ApplicationHandlerLo End Select End Function - -Public Property Get MdiBackColor() As Long -'/** -' * @bug Ermitteln der Hintergrundfarbe des MDI-Bereichs Funktioniert nicht unter Access 2007 -'**/ - If m_CustomMDIBackgroundColor <> 0 Then - MdiBackColor = m_CustomMDIBackgroundColor - Else - MdiBackColor = GetSysColor(SYSCOLOR_COLOR_APPWORKSPACE) - End If -End Property - -Friend Property Let MdiBackColor(ByVal Color As Long) - - Dim NewBrush As Long - Dim hMDI As Long - - m_CustomMDIBackgroundColor = Color - hMDI = FindWindowEx(Application.hWndAccessApp, 0&, "MDIClient", vbNullString) - - 'Brush erzeugen - NewBrush = CreateSolidBrush(m_CustomMDIBackgroundColor) - 'Brush zuweisen - SetClassLong hMDI, GCL_HBRBACKGROUND, NewBrush - 'Fenster neuzeichnen (gesamtes Fenster inkl. Background) - RedrawWindow hMDI, ByVal 0&, ByVal 0&, RDW_INVALIDATE Or RDW_ERASE - -End Property - - '--------------------------------------------------------------------------------------- ' Function: CreateAppFile '--------------------------------------------------------------------------------------- -'/** -' -' Datei aus AppFile-Tabelle extrahieren -' -' Kennung in Tabelle -' -' True = Datei wurde gespeichert -' -' Erfordert AppFile-Erweiterung (wird über Ereignis-Schnittstelle angesprochen) -' -'**/ +' +' 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 ' Rückgabewert aus Event-Schnittstelle - Dim EventResumeMessage As Variant ' Nachricht, für Abbruchgrund (wird derzeit noch nicht genutzt) + Dim EventResumeMode As ApplicationHandlerResumeModes ' Return value from event interface + Dim EventResumeMessage As Variant ' Message, for termination reason (currently not used) '--------------------------------------------------- - ' Schnittstelle für andere Klassen .. damit wird es möglich, - ' dass die Erstellung der Datei eine andere Klasse übernimmt + ' 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) @@ -705,26 +611,31 @@ End Function '--------------------------------------------------------------------------------------- ' Function: SaveAppFile '--------------------------------------------------------------------------------------- -'/ -' -' Datei in AppFile-Tabelle speichern -' -' Kennung in Tabelle (Feld "id") -' Dateiname -' Version abspeichern -' -' Erfordert ApplicationHandler_File (wird über Ereignis-Schnittstelle angesprochen) -' -'/ +' +' 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 ' Rückgabewert aus Event-Schnittstelle - Dim EventResumeMessage As Variant ' Nachricht, für Abbruchgrund + Dim EventResumeMode As ApplicationHandlerResumeModes ' Return value from event interface + Dim EventResumeMessage As Variant ' Message, for termination reason '--------------------------------------------------- - ' Event-Schnittstelle AppFileBeforeSaveFile + ' Event interface AppFileBeforeSaveFile ' EventResumeMode = 0 RaiseEvent AppFileBeforeSaveFile(FileID, FileName, SaveVersion, EventResumeMode, EventResumeMessage, ExtFieldName, ExtFieldValue) @@ -737,12 +648,53 @@ Friend Function SaveAppFile(ByVal FileID As String, ByVal FileName As String, Op 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 -'Anm.: auf Auflistungs-Klasse verzichtet .. der Code ist zwar nicht so elegant, dafür ist eine kaum verwendete Klasse weniger +'Note: collection class waived .. the code is not so elegant, but one less hardly used class '/** -' * @todo sollte man eine Schnittstelle statt Late binding verwenden? +' * @todo Should you use an interface instead of late binding? '**/ Dim ExtRef As Object @@ -777,12 +729,11 @@ Public Function GetExtensionProperty(ByVal ExtensionKey As String, ByVal Propert End Function - Public Function UpdateApplication() As Boolean -' True = Anwendung schließen +' True = Close application -' => Ausgelager an Erweiterung: damit wird die Verwendugn flexibler -' und jeder kann sich aussuchen nach welcher Update-Methode vorgegangen werden soll +' => 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 @@ -796,37 +747,19 @@ Public Function UpdateApplication() As Boolean End Function -Private Function CheckVersionUpdate() As Boolean -' True = Update erforderlich - - 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 - '--------------------------------------------------------------------------------------- -' Sub: CallExtensionProcedure (Josef Pötzl, 2010-03-13) +' Sub: CallExtensionProcedure '--------------------------------------------------------------------------------------- -'/** -' -' Prozeduren aus Erweiterungen aufrufen -' -' Extension-Kennung -' Name der zu startenden Prozedur -' Rückgabekennung -' Antwort -' Array für Übergabe- und Rückgabeparameter -' -' -' -'**/ +' +' 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, _ @@ -835,14 +768,3 @@ Public Sub CallExtensionProcedure(ByVal Key As String, ByVal ProcedureName As St RaiseEvent ExtensionProcedureCall(Key, ProcedureName, ResumeMode, ResumeMessage, Params) End Sub - -Public Function NewerAppVersionExists() As Boolean - - Dim ResumeMode As ApplicationHandlerResumeModes - Dim ResumeMessage As Boolean - - RaiseEvent NewVersionExists(ResumeMode, ResumeMessage) - - NewerAppVersionExists = ResumeMessage - -End Function diff --git a/access-add-in/source/codelib/base/ApplicationHandler_AppFile.cls b/access-add-in/source/codelib/base/ApplicationHandler_AppFile.cls index 4fe3dbc..f4c3baf 100644 --- a/access-add-in/source/codelib/base/ApplicationHandler_AppFile.cls +++ b/access-add-in/source/codelib/base/ApplicationHandler_AppFile.cls @@ -9,20 +9,20 @@ Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Attribute VB_Description = "Erweiterung für ApplicationHandler-Klasse: Anwendungsspezifische Dateien verwalten" '--------------------------------------------------------------------------------------- -' Klassenmodul: ApplicationHandler_File (Josef Pötzl, 2009-12-11) +' Class: base.ApplicationHandler_File '--------------------------------------------------------------------------------------- -'/** -' -' Erweiterung für ApplicationHandler-Klasse: Anwendungsspezifische Dateien verwalten -' -' -' Aktivierung im _config_Application-Modul:\n -' modApplication.AddApplicationHandlerExtension New ApplicationHandler_AppFile -' oder mittels ExtensionCollection:\n -' ExtensionsCollectionReferenz.Add New ApplicationHandler_AppFile -' -'\ingroup base -'**/ +' +' Extension for ApplicationHandler class: manage application-specific files +' +' Author: +' Josef Poetzl +' +' Remarks: +' Activation in the _config_Application module: +' ExtensionsCollectionReferenz.Add New ApplicationHandler_AppFile +' +'--------------------------------------------------------------------------------------- + '--------------------------------------------------------------------------------------- ' ' base/ApplicationHandler_AppFile.cls @@ -46,7 +46,7 @@ Private Const TABLE_FIELD_FILE As String = "file" '--------------------------------------------------------------------------------------- -' Standard-Initialisierung von Erweiterungen +' Standard initialization of extensions '--------------------------------------------------------------------------------------- Private WithEvents m_ApplicationHandler As ApplicationHandler @@ -61,7 +61,7 @@ Public Property Get ExtensionKey() As String End Property '--------------------------------------------------------------------------------------- -' Standard-Ereignisbehandlung von Erweiterungen +' Standard event handling of extensions '--------------------------------------------------------------------------------------- ' CheckExtension @@ -89,14 +89,13 @@ End Sub ' AfterDispose Private Sub m_ApplicationHandler_AfterDispose(ByRef ResumeMode As ApplicationHandlerResumeModes, ByRef ResumeMessage As Variant) -'=> Referenz in m_ApplicationHandler auf Nothing setzen +'=> Set reference in m_ApplicationHandler to Nothing Set m_ApplicationHandler = Nothing End Sub - '--------------------------------------------------------------------------------------- -' Ergänzungen für Ereiterung: ApplicationHandler_AppFile +' Additions for extension: ApplicationHandler_AppFile '--------------------------------------------------------------------------------------- ' @@ -122,33 +121,26 @@ Public Property Get AppFileTableName() As String End Property '--------------------------------------------------------------------------------------- -' Function: CreateAppFile (2009-07-30) +' Function: CreateAppFile '--------------------------------------------------------------------------------------- -'/** -' -' Datei aus usys_AppFiles extrahieren -' -' Datensatzkennung -' zu erzeugender Dateiname -' Boolean -' -' -'**/ +' +' Extract file from usys_AppFiles +' +' Parameters: +' FileID - Record identifier +' FileName - File name to be created +' +' Returns: +' Boolean +' '--------------------------------------------------------------------------------------- -Public Function CreateAppFile(ByVal FileID As String, ByVal FileName As String, _ - Optional ByVal ExtFilterFieldName As String, Optional ExtFilterValue As Variant) As Boolean +Public Function CreateAppFile(ByVal FileID As String, ByVal FileName As String) As Boolean Dim Binfile() As Byte Dim FieldSize As Long Dim fld As DAO.Field - Dim SelectSql As String - - SelectSql = "select " & TABLE_FIELD_FILE & " from " & TABLE_APPFILES & " where " & TABLE_FIELD_ID & "='" & Replace(FileID, "'", "''") & "'" - If Len(ExtFilterFieldName) > 0 Then - SelectSql = SelectSql & " and " & ExtFilterFieldName & " = '" & Replace(ExtFilterValue, "'", "''") & "'" - End If - With CodeDb.OpenRecordset(SelectSql) + With CodeDb.OpenRecordset("select " & TABLE_FIELD_FILE & " from " & TABLE_APPFILES & " where " & TABLE_FIELD_ID & "='" & Replace(FileID, "'", "''") & "'") If Not .EOF Then Set fld = .Fields(0) @@ -183,16 +175,19 @@ End Sub '--------------------------------------------------------------------------------------- ' Function: SaveAppFile '--------------------------------------------------------------------------------------- -'/ -' +' ' Datei in usys_AppFiles speichern -' -' Kennung in Tabelle (Feld "id") -' Dateiname -' Version abspeichern -' -' -'/ +' +' 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 +' '--------------------------------------------------------------------------------------- Public Function SaveAppFile(ByVal FileID As String, ByVal FileName As String, _ Optional ByVal SaveVersion As Boolean = False, _ @@ -295,8 +290,9 @@ End Function '--------------------------------------------------------------------------------------- -' Ereignisbehandlung von m_ApplicationHandler +' Event handling of m_ApplicationHandler ' + ' AppFileBeforeCreateFile Private Sub m_ApplicationHandler_AppFileBeforeCreateFile(ByVal FileID As String, ByVal FileName As String, _ ByRef ResumeMode As ApplicationHandlerResumeModes, ByRef ResumeMessage As Variant) @@ -323,7 +319,7 @@ Private Sub m_ApplicationHandler_AppFileBeforeSaveFile(ByVal FileID As String, B Completed = SaveAppFile(FileID, FileName, SaveVersion, ExtFieldName, ExtFieldValue) If Completed Then ResumeMode = ApplicationHandlerResumeModes.AppResumeMode_Completed - Else 'Fehler rückmelden + Else 'resume error ResumeMode = ApplicationHandlerResumeModes.AppResumeMode_Error End If diff --git a/access-add-in/source/codelib/base/ApplicationHandler_ExtensionCollection.cls b/access-add-in/source/codelib/base/ApplicationHandler_ExtensionCollection.cls index 2cac516..66233f5 100644 --- a/access-add-in/source/codelib/base/ApplicationHandler_ExtensionCollection.cls +++ b/access-add-in/source/codelib/base/ApplicationHandler_ExtensionCollection.cls @@ -8,27 +8,29 @@ Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False '--------------------------------------------------------------------------------------- -' Klassenmodul: ApplicationHandler_ExtensionCollection +' Class: base.ApplicationHandler_ExtensionCollection '--------------------------------------------------------------------------------------- -'/** -' -' Einbindung der Erweiterungen für ApplicationHandler-Framework -' -' -' Verwendung im _config_Application-Modul:\n +' +' Integration of the extensions for ApplicationHandler framework +' +' Author: +' Josef Poetzl +' +' Remarks: +' Use in the _config_Application module: ' ' Set m_Extensions = New ApplicationHandler_ExtensionCollection ' With m_Extensions ' Set .ApplicationHandler = oCurrentAppHandler ' -' ' Erweiterungen laden (z. B. ApplicationHandler_DbConnection): +' ' Load extensions (e.g. ApplicationHandler_DbConnection): ' .Add New ApplicationHandler_DbConnection ' ' End With ' -' -'\ingroup base -'**/ +' +'--------------------------------------------------------------------------------------- + '--------------------------------------------------------------------------------------- ' ' base/ApplicationHandler_ExtensionCollection.cls @@ -46,14 +48,11 @@ Private m_Extension As Collection Private m_Disposed As Boolean '--------------------------------------------------------------------------------------- -' Sub: Extensions +' Property: Extensions '--------------------------------------------------------------------------------------- -'/** -' -' Collection der Erweiterungen -' -' -'**/ +' +' Collection of extensions +' '--------------------------------------------------------------------------------------- Public Property Get Extensions() As Collection If m_Extension Is Nothing Then @@ -73,18 +72,17 @@ End Property '--------------------------------------------------------------------------------------- ' Sub: Add '--------------------------------------------------------------------------------------- -'/** -' -' Erweiterung zu Collection hinzufügen -' -' Referenz auf Instanz der Erweiterung -' -' Referenz wird in Collection abgelegt, damit keine zusätzliche (manuelle) -' Referenzspeicherung notwendig ist. -' -'**/ +' +' Add extension to collection +' +' Parameters: +' ExtensionRef - Reference to instance of extension +' +' Remarks: +' Reference is stored in Collection so that no additional (manual) reference storage is necessary. +' '--------------------------------------------------------------------------------------- -Public Sub Add(ByRef ExtensionRef As Object) +Public Sub Add(ByVal ExtensionRef As Object) Set ExtensionRef.ApplicationHandlerRef = CurrentApplication Extensions.Add ExtensionRef, ExtensionRef.ExtensionKey End Sub @@ -97,7 +95,7 @@ Public Sub Dispose() On Error Resume Next If Not (m_Extension Is Nothing) Then - MaxCnt = m_Extension.Count * 2 'nur zur Sicherheit falls wider Erwarten m_Extension.Remove eine Endlosschleife bringen würde + MaxCnt = m_Extension.Count * 2 'just to be on the safe side in case m_Extension.Remove would bring an infinite loop against expectations Do While m_Extension.Count > 0 Or CheckCnt > MaxCnt m_Extension.Remove 1 CheckCnt = CheckCnt + 1 diff --git a/access-add-in/source/codelib/base/_initApplication.bas b/access-add-in/source/codelib/base/_initApplication.bas index f13145c..3db9603 100644 --- a/access-add-in/source/codelib/base/_initApplication.bas +++ b/access-add-in/source/codelib/base/_initApplication.bas @@ -1,22 +1,20 @@ Attribute VB_Name = "_initApplication" '--------------------------------------------------------------------------------------- -' Modul: _initApplication (2009-07-08) +' Package: base._initApplication '--------------------------------------------------------------------------------------- -'/** -' -' Initialisierungsaufruf der Anwendung -' -' -' -' \ingroup base -' @todo StartApplication-Prozedur für allgemeine Verwendung umschreiben => in Klasse verlagern -'**/ +' +' Initialising the application +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + '--------------------------------------------------------------------------------------- ' ' base/_initApplication.bas ' _codelib/license.bas ' base/modApplication.bas -' base/defGlobal.bas ' '--------------------------------------------------------------------------------------- ' @@ -28,21 +26,19 @@ Option Private Module ' Anwendungseinstellungen '------------------------- ' -' => siehe _config_Application +' => see _config_Application ' '------------------------- '--------------------------------------------------------------------------------------- ' Function: StartApplication '--------------------------------------------------------------------------------------- -'/** -' -' Prozedur für den Anwendungsstart -' -' Boolean -' -' -'**/ +' +' Procedure for application start-up +' +' Returns: +' Boolean - sucess = true +' '--------------------------------------------------------------------------------------- Public Function StartApplication() As Boolean @@ -55,7 +51,7 @@ ExitHere: HandleErr: StartApplication = False - MsgBox "Anwendung kann nicht gestartet werden.", vbCritical, CurrentApplicationName + MsgBox "Application can not be started.", vbCritical, CurrentApplicationName Application.Quit acQuitSaveNone Resume ExitHere diff --git a/access-add-in/source/codelib/base/modApplication.bas b/access-add-in/source/codelib/base/modApplication.bas index ab577af..c8a3e42 100644 --- a/access-add-in/source/codelib/base/modApplication.bas +++ b/access-add-in/source/codelib/base/modApplication.bas @@ -1,16 +1,16 @@ Attribute VB_Name = "modApplication" Attribute VB_Description = "Standard-Prozeduren für die Arbeit mit ApplicationHandler" '--------------------------------------------------------------------------------------- -' Module: modApplication +' Package: base.modApplication '--------------------------------------------------------------------------------------- -'/** -' -' Standard-Prozeduren für die Arbeit mit ApplicationHandler -' -' -' -' \ingroup base -'**/ +' +' Standard procedures for working with ApplicationHandler +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + '--------------------------------------------------------------------------------------- ' ' base/modApplication.bas @@ -24,23 +24,17 @@ Option Compare Text Option Explicit Option Private Module -' Instanz der Hauptsteuerung +' Instance of the main control Private m_ApplicationHandler As ApplicationHandler - -' Erweiterungen zu ApplicationHandler (Ansteuerung erfolgt über Ereignisse von ApplicationHandler) -Private m_Extension As Collection +Private m_ApplicationName As String ' Cache for application names + ' if CurrentApplication.ApplicationName is not running '--------------------------------------------------------------------------------------- ' Property: CurrentApplication '--------------------------------------------------------------------------------------- -'/** -' -' Property für ApplicationHandler-Instanz (diese Property im Code verwenden) -' -' aktuelle Instanz von ApplicationHandler -' -' -'**/ +' +' Property for ApplicationHandler instance (use this property in code) +' '--------------------------------------------------------------------------------------- Public Property Get CurrentApplication() As ApplicationHandler If m_ApplicationHandler Is Nothing Then @@ -50,43 +44,58 @@ Public Property Get CurrentApplication() As ApplicationHandler End Property '--------------------------------------------------------------------------------------- -' Sub: AddApplicationHandlerExtension -'--------------------------------------------------------------------------------------- -'/** -' -' Erweiterung zu Collection hinzufügen -' -' Referenz auf Instanz der Erweiterung -' -' Referenz wird in Collection abgelegt, damit keine zusätzliche (manuelle) -' Referenzspeicherung notwendig ist. -' -'**/ -'--------------------------------------------------------------------------------------- -Public Sub AddApplicationHandlerExtension(ByRef ObjRef As Object) -' --- DEPRECATED ! --- -' Durch Klasse ApplicationHandler_ExtensionCollection ersetzt. -Stop - If m_Extension Is Nothing Then - Set m_Extension = New Collection +' 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 - Set ObjRef.ApplicationHandlerRef = CurrentApplication - m_Extension.Add ObjRef, ObjRef.ExtensionKey -End Sub + 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 @@ -94,10 +103,7 @@ End Sub Private Sub InitApplication() - ' Hauptinstanz erzeugen Set m_ApplicationHandler = New ApplicationHandler - - 'Einstellungen initialisieren Call InitConfig(m_ApplicationHandler) End Sub @@ -106,13 +112,9 @@ End Sub '--------------------------------------------------------------------------------------- ' Sub: DisposeCurrentApplicationHandler '--------------------------------------------------------------------------------------- -'/** -' -' Instanz von ApplicationHandler und den Erweiterungen zerstören -' -' -' -'**/ +' +' Destroy instance of ApplicationHandler and the extensions +' '--------------------------------------------------------------------------------------- Public Sub DisposeCurrentApplicationHandler() @@ -123,19 +125,6 @@ On Error Resume Next If Not m_ApplicationHandler Is Nothing Then m_ApplicationHandler.Dispose End If - - If Not (m_Extension Is Nothing) Then - ' --- DEPRECATED ! --- - ' Durch Klasse ApplicationHandler_ExtensionCollection ersetzt. - Stop - WriteApplicationLogEntry "DisposeCurrentApplicationHandler: m_Extension in modApplication durch Klasse ApplicationHandler_ExtensionCollection ersetzt.", AppLogType_Error - MaxCnt = m_Extension.Count * 2 'nur zur Sicherheit falls wider Erwarten m_Extension.Remove eine Endlosschleife bringen würde - Do While m_Extension.Count > 0 Or CheckCnt > MaxCnt - m_Extension.Remove 1 - CheckCnt = CheckCnt + 1 - Loop - Set m_Extension = Nothing - End If Set m_ApplicationHandler = Nothing @@ -144,7 +133,7 @@ End Sub '--------------------------------------------------------------------------------------- ' -' Hilfsprozeduren +' Auxiliary procedures Public Sub WriteApplicationLogEntry(ByVal Msg As String, _ Optional LogType As ApplicationHandlerLogType, _ Optional ByVal Args As Variant) diff --git a/access-add-in/source/codelib/base/modErrorHandler.bas b/access-add-in/source/codelib/base/modErrorHandler.bas new file mode 100644 index 0000000..326f2d4 --- /dev/null +++ b/access-add-in/source/codelib/base/modErrorHandler.bas @@ -0,0 +1,310 @@ +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) Then + PrintToFile ErrNumber, NewErrSource, NewErrDescription + ErrHandlerMode = ErrHandlerMode - ACLibErrorHandlerMode.aclibErrFile + 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 + ShowErrorMessage ErrNumber, NewErrSource, NewErrDescription + 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/access-add-in/source/codelib/data/SqlTools.cls b/access-add-in/source/codelib/data/SqlTools.cls index d3ca612..14fb6ac 100644 --- a/access-add-in/source/codelib/data/SqlTools.cls +++ b/access-add-in/source/codelib/data/SqlTools.cls @@ -7,21 +7,23 @@ Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False -'Attribute VB_PredeclaredId = True '--------------------------------------------------------------------------------------- -' Klasse: SqlTools +' Class: data.sql.SqlTools '--------------------------------------------------------------------------------------- -'/** -' \author Josef Poetzl -' -' SQL-Hilfsfunktionen -' -' Attribute VB_PredeclaredId = True einstellen, damit SqlTools ohne explizite Instanzierung genutzt werden kann +' Functions to build sql strings ' -' \warning Nicht vergessen: Parameter für Datumsformat, Boolean und WildCard für das DBMS einstellen +' Author: +' Josef Poetzl ' -' \ingroup data -'**/ +' 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 @@ -39,15 +41,15 @@ Private Enum SqlToolsErrorNumbers ERRNR_NOCONFIG = vbObjectError + 1 End Enum -' Standard-Werte für Methodenparameter +' Default values for method parameters Private Const SQL_DEFAULT_TEXTDELIMITER As String = "'" -Private Const SQL_DEFAULT_DATEFORMAT As String = "" ' "" => SqlDateFormat-Eigenschaft wird verwenden. - ' Zum Deaktivieren Wert eintragen (z. B. "\#yyyy\-mm\-dd\#"), - ' dann wird dieser Wert als Standardeintrag verwendet. -Private Const SQL_DEFAULT_BOOLTRUESTRING As String = "" ' "" => SqlBooleanTrueString wird verwendet. - ' Zum Deaktivieren Wert eintragen (z. B. "True oder 1") -Private Const SQL_DEFAULT_WILDCARD As String = "%" ' * = Standardwert, - ' benötigte Abweichungen über SqlWildCardString einstellen +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 " @@ -88,16 +90,101 @@ Public Enum SqlLogicalOperator SQL_CommaSeparator = 3 End Enum -' SQL-Dialekt-Voreinstellungen +'################################## +' 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.Clone("\#yyyy-mm-dd hh:nn:ss\#", "True", "*") + 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.Clone("'yyyymmdd hh:nn:ss'", "1", "%") + Set TSql = Me.NewInstance("'yyyymmdd hh:nn:ss'", "1", "%") End Property -' Konfiguration für den SQL-Dialekt +' 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 @@ -110,6 +197,13 @@ 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 @@ -122,6 +216,13 @@ 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 @@ -134,59 +235,187 @@ Public Property Let SqlBooleanTrueString(ByVal NewValue As String) m_SqlBooleanTrueString = NewValue End Property +'################################## +' Group: BuildCriteria + '--------------------------------------------------------------------------------------- -' Function: Clone +' Function: BuildCriteria '--------------------------------------------------------------------------------------- -'/** -' -' Neue Instanz mit Grundeinstellungen der aktuellen Instanz erstellen. -' -' String -' -' -'**/ +' +' 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 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 +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 (RelationalOperator And SQL_SplitValueToArray) = SQL_SplitValueToArray Then + If InStr(1, FilterValue, ";") > 0 Then + FilterValue = Split(CharTrim(FilterValue, ";"), ";") + End If + RelationalOperator = RelationalOperator Xor SQL_SplitValueToArray + End If + + 'Special cases (part 2): + If Not IsArray(FilterValue) Then + + If FieldDataType = SQL_Numeric 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 Len(NewSqlDateFormat) = 0 Then NewSqlDateFormat = Me.SqlDateFormat - If Len(NewSqlBooleanTrueString) = 0 Then NewSqlBooleanTrueString = Me.SqlBooleanTrueString - If Len(NewSqlWildCardString) = 0 Then NewSqlWildCardString = Me.SqlWildCardString + If TryBuildArrayCriteria(FieldName, FieldDataType, RelationalOperator, FilterValue, IgnoreValue, Criteria) Then + BuildCriteria = Criteria + Exit Function + End If - Set Clone = NewInstance(NewSqlDateFormat, NewSqlBooleanTrueString, NewSqlWildCardString) + If TryBuildBetweenCriteria(FieldName, FieldDataType, RelationalOperator, FilterValue, FilterValue2, IgnoreValue, Criteria) Then + BuildCriteria = Criteria + Exit Function + End If -End Function + If (RelationalOperator And SQL_Like) = SQL_Like 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 -Public Function NewInstance(ByVal NewSqlDateFormat As String, _ - ByVal NewSqlBooleanTrueString As String, _ - ByVal NewSqlWildCardString As String) As SqlTools + 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 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 - Dim NewInst As SqlTools + OperatorString = GetRelationalOperatorString(RelationalOperator) - Set NewInst = New SqlTools - With NewInst - .SqlDateFormat = NewSqlDateFormat - .SqlBooleanTrueString = NewSqlBooleanTrueString - .SqlWildCardString = NewSqlWildCardString - End With + Criteria = FieldName & " " & OperatorString & " " & FilterValueString - Set NewInstance = NewInst + 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: DateToSqlText +' Function: ConvertToSqlText '--------------------------------------------------------------------------------------- -'/** -' -' Werte in String für SQL-Anweisung umwandeln, die per VBA zusammengesetzt wird. -' -' Übergabewert -' Datentyp des zu konvertierenden Wertes -' String -'**/ +' +' 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 @@ -209,19 +438,21 @@ End Function '--------------------------------------------------------------------------------------- ' Function: TextToSqlText '--------------------------------------------------------------------------------------- -'/** -' -' Text für SQL-Anweisung aufbereiten. -' -' Übergabewert -' Begrenzungszeichen für Text-Werte. (In den meisten DBMS wird ' als Begrenzungszeichen verwendet.) -' Nur Begrenzungszeichnen innerhalb des Werte verdoppeln, Eingrenzung jedoch nicht setzen. -' String -' -' Beispiel: strSQL = "select ... from tabelle where Feld = " & TextToSqlText("ab'cd") -' => strSQL = "select ... from tabelle where Feld = 'ab''cd'" -' -'**/ +' +' 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, _ @@ -246,14 +477,16 @@ End Function '--------------------------------------------------------------------------------------- ' Function: DateToSqlText '--------------------------------------------------------------------------------------- -'/** -' -' Datumswert in String für SQL-Anweisung umwandeln, die per VBA zusammengesetzt wird. -' -' Übergabewert -' Datumsformat (von DBMS abhängig!) -' String -'**/ +' +' 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 @@ -281,16 +514,19 @@ End Function '--------------------------------------------------------------------------------------- ' Function: NumberToSqlText '--------------------------------------------------------------------------------------- -'/** -' -' Zahl für SQL-Text aufbereiten -' -' Übergabewert -' String -' -' Durch Str-Funktion wird . statt , verwendet. -' -'**/ +' +' 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 @@ -312,11 +548,13 @@ Public Function NumberToSqlText(ByVal Value As Variant) As String End Function -Private Function ConvertToNumeric(ByVal Value As Variant) As Variant +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 @@ -328,21 +566,20 @@ Private 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 @@ -350,15 +587,16 @@ End Function '--------------------------------------------------------------------------------------- ' Function: BooleanToSqlText '--------------------------------------------------------------------------------------- -'/** -' -' Boolean für SQL-Text aufbereiten -' -' Übergabewert -' String -' -' -'**/ +' +' 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 @@ -368,7 +606,7 @@ Public Function BooleanToSqlText(ByVal Value As Variant, _ Exit Function End If - If Value = True Then + 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 @@ -382,233 +620,6 @@ Public Function BooleanToSqlText(ByVal Value As Variant, _ End Function -'--------------------------------------------------------------------------------------- -' Function: BuildCriteria -'--------------------------------------------------------------------------------------- -'/** -' -' SQL-Kriterium erstellen -' -' Feldname in der Datenquelle, die gefiltert werden soll -' Vergleichsoperator (=, <=, usw.) -' Filterwert (kann einzelner Wert oder auch Array mit Werten sein) -' Optionale 2. Filterwert (für Between) -' Jener Wert, für den keine Filterbedingung erzeugt werden soll. (Array-Übergabe von Werten möglich) -' 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 = Null, _ - Optional ByVal DisableIgnoreNullValue As Boolean = False) As String - - Dim FilterValueString As String - Dim OperatorString As String - Dim Criteria As String - Dim Criteria1 As String - Dim Criteria2 As String - Dim TempArr() As String - - If (RelationalOperator And [_IgnoreAll]) = [_IgnoreAll] Then - Exit Function - End If - - 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) - 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 (RelationalOperator And SQL_SplitValueToArray) = SQL_SplitValueToArray Then - If InStr(1, FilterValue, ";") > 0 Then - FilterValue = Split(CharTrim(FilterValue, ";"), ";") - End If - RelationalOperator = RelationalOperator Xor SQL_SplitValueToArray - End If - - 'Sonderfälle: - If Not IsArray(FilterValue) Then - - If FieldDataType = SQL_Numeric 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 - - FilterValue = Trim(FilterValue) - - If FilterValue Like "[0-9]*..*[0-9]*" Or FilterValue Like "[+-][0-9]*..*[0-9]*" Then - TempArr = Split(FilterValue, "..") - BuildCriteria = BuildCriteria(FieldName, FieldDataType, SQL_Between, Trim(TempArr(0)), Trim(TempArr(1)), IgnoreValue, DisableIgnoreNullValue) - Exit Function - End If - - If 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, "..") - BuildCriteria = BuildCriteria(FieldName, FieldDataType, SQL_Between, Trim(TempArr(0)), Trim(TempArr(1)), IgnoreValue, DisableIgnoreNullValue) - Exit Function - - End If - - If FilterValue Like "*[0-9]" & DecimalMarker & "*[*]" Then - If (RelationalOperator And SQL_Add_WildCardSuffix) = 0 Then - BuildCriteria = BuildCriteria(FieldName, FieldDataType, RelationalOperator + SQL_Add_WildCardSuffix, FilterValue, FilterValue2, IgnoreValue, DisableIgnoreNullValue) - Exit Function - End If - 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 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 (RelationalOperator And SQL_Like) = SQL_Like Then - FilterValue = FilterValue & SqlWildCardString - ElseIf (FieldDataType And SQL_Date) = SQL_Date Then - If (RelationalOperator And SQL_LessThan) = 0 Then ' kein < daher: >, >= oder nur = - If (RelationalOperator And SQL_GreaterThan) = SQL_GreaterThan Then - ' nichts ändern => >= DataValue / SQL_Add_WildCardSuffix ist nicht logisch - Else ' ganzen Tag berücksichtigen FieldName >= DateValue and FieldName < DateAdd("d", 1, FilterValue)) - BuildCriteria = BuildCriteria(FieldName, FieldDataType, SQL_GreaterThan + SQL_Equal, FilterValue) & _ - SqlAndConcatString & _ - BuildCriteria(FieldName, FieldDataType, SQL_LessThan, DateAdd("d", 1, CDate(CLng(FilterValue)))) - 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(FilterValue))) - End If - ElseIf (FieldDataType And SQL_Numeric) = SQL_Numeric Then - If (RelationalOperator And SQL_LessThan) = 0 Then ' kein < daher: >, >= oder nur = - 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 - ' nichts ändern => >= Zahl / SQL_Add_WildCardSuffix ist nicht logisch - Else ' nachfolgende Dezimalwerte berücksichtigen FieldName >= Zahl and FieldName < (Zahl + 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)) - Criteria2 = BuildCriteria(FieldName, FieldDataType, SQL_LessThan + SQL_Equal, FilterValue2) - Else - Criteria1 = BuildCriteria(FieldName, FieldDataType, SQL_GreaterThan + SQL_Equal, FilterValue) - Criteria2 = BuildCriteria(FieldName, FieldDataType, SQL_LessThan, GetNextDigitNumber(FilterValue)) - End If - BuildCriteria = Criteria1 & SqlAndConcatString & Criteria2 - 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 If - - If (RelationalOperator And SQL_Add_WildCardPrefix) = SQL_Add_WildCardPrefix Then - If (RelationalOperator And SQL_Like) = SQL_Like 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 - Criteria = "Not " & Criteria - End If - - BuildCriteria = Criteria - -End Function - Private Function ConfigNumericSpecials( _ ByRef RelationalOperator As SqlRelationalOperators, _ ByRef FilterValue As Variant, _ @@ -665,7 +676,7 @@ Private Function GetNextDigitNumber(ByVal Z As Variant, Optional AddToAbsoluteVa End If KommaPos = InStrRev(TestString, DecimalMarker) - If KommaPos = 0 Then ' nächste Ganzzahl + If KommaPos = 0 Then ' next integer If AddToAbsoluteValue And IsNegativ Then GetNextDigitNumber = CDbl(Replace(CStr(Z), "*", vbNullString)) - 1 Else @@ -691,11 +702,11 @@ End Function Private Property Get DecimalMarker() As String Static DecChar As String - Dim x As String + Dim X As String If Len(DecChar) = 0 Then - x = Trim(CStr(1.2)) - DecChar = Mid(x, 2, 1) + X = Trim(CStr(1.2)) + DecChar = Mid(X, 2, 1) End If DecimalMarker = DecChar @@ -734,7 +745,6 @@ Friend Function GetRelationalOperatorString(ByRef RelationalOperator As SqlRelat Exit Function End If - If (RelationalOperator And SQL_Not) = SQL_Not Then op = RelationalOperator Xor SQL_Not @@ -777,6 +787,113 @@ Friend Function GetRelationalOperatorString(ByRef RelationalOperator As SqlRelat 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 Then + FilterValue = FilterValue & SqlWildCardString + ElseIf (FieldDataType And SQL_Date) = 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(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(FilterValue))) + End If + ElseIf (FieldDataType And SQL_Numeric) = 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 + + FilterValue = Trim(FilterValue) + + 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 TryBuildArrayCriteria(ByRef FieldName As String, ByVal FieldDataType As SqlFieldDataType, _ ByRef RelationalOperator As SqlRelationalOperators, _ ByRef FilterValue As Variant, _ @@ -791,9 +908,9 @@ Private Function TryBuildArrayCriteria(ByRef FieldName As String, ByVal FieldDat Exit Function End If - 'Kriterien über Or verbinden + 'Connect criteria via Or For Each itm In FilterValue - ItmCriteria = BuildCriteria(FieldName, FieldDataType, RelationalOperator, itm, , IgnoreValue) + ItmCriteria = BuildCriteria(FieldName, FieldDataType, RelationalOperator, itm, , IgnoreValue, False) If Len(ItmCriteria) > 0 Then Criteria = Criteria & SqlOrConcatString & ItmCriteria End If @@ -821,8 +938,16 @@ Private Function TryBuildInCriteria(ByRef FieldName As String, ByVal FieldDataTy If IsArray(FilterValue) Then FilterValueString = GetValueArrayString(FilterValue, FieldDataType, ",", IgnoreValue) - ElseIf VarType(FilterValue) = vbString Then ' Value ist bereits die Auflistung als String - FilterValueString = FilterValue + 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 @@ -864,21 +989,21 @@ Private Function TryBuildBetweenCriteria(ByRef FieldName As String, ByVal FieldD Exit Function End If - If (RelationalOperator And SQL_Not) = SQL_Not Then 'Bedingung umdrehen - Criteria1 = BuildCriteria(FieldName, FieldDataType, SQL_LessThan, FilterValue, , IgnoreValue) - Criteria2 = BuildCriteria(FieldName, FieldDataType, SQL_GreaterThan, FilterValue2, , IgnoreValue) + 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 'wegschneiden + 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) - Criteria2 = BuildCriteria(FieldName, FieldDataType, SQL_LessThan, FilterValue2) + 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 @@ -892,14 +1017,14 @@ Private Function TryBuildBetweenCriteria(ByRef FieldName As String, ByVal FieldD 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) - Criteria2 = BuildCriteria(FieldName, FieldDataType, SQL_LessThan + SQL_Equal + SQL_Add_WildCardSuffix, FilterValue2) + 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) - Criteria2 = BuildCriteria(FieldName, FieldDataType, SQL_LessThan + SQL_Equal + SQL_Add_WildCardSuffix, FilterValue2) + 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 @@ -920,7 +1045,7 @@ Private Function GetCheckedIgnoreValue(ByVal IgnoreValue As Variant) As Variant End Function Private Function NullFilterOrEmptyFilter(ByVal FieldName As String, ByVal FieldDataType As SqlFieldDataType, _ - ByVal RelationalOperator As SqlRelationalOperators, _ + ByVal RelationalOperator As SqlRelationalOperators, _ ByVal Value As Variant, ByVal IgnoreValue As Variant, _ ByRef NullFilterString As String, _ Optional ByVal DisableIgnoreNullValue As Boolean = False) As Boolean diff --git a/access-add-in/source/codelib/data/dao/DaoHandler.cls b/access-add-in/source/codelib/data/dao/DaoHandler.cls index 8387a82..0317c79 100644 --- a/access-add-in/source/codelib/data/dao/DaoHandler.cls +++ b/access-add-in/source/codelib/data/dao/DaoHandler.cls @@ -8,16 +8,16 @@ Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False '--------------------------------------------------------------------------------------- -' Class: DaoHandler +' Class: data.dao.DaoHandler '--------------------------------------------------------------------------------------- -'/** -' \author Josef Poetzl -' -' DAO-Zugriffsmethoden -' -' -'\ingroup data_dao -'**/ +' +' DAO data connection methods +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + '--------------------------------------------------------------------------------------- ' ' data/dao/DaoHandler.cls @@ -36,26 +36,37 @@ Option Explicit Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Dest As Any, ByRef Source As Any, ByVal Bytes As Long) #End If -'DAO-Database +'DAO Database Private m_DaoDb As DAO.Database -'Standardwerte für optionale DAO-Enum-Paramter z. B. in OpenRecordset -' (falls diese nicht gesetzt sind, gilt DAO-Standard) +'Default values for optional DAO enum parameters, e.g. in OpenRecordset. +' (if these are not set, DAO standard applies) Private m_RecordsetTypeEnumDefault As DAO.RecordsetTypeEnum Private m_RecordsetOptionEnumDefault As DAO.RecordsetOptionEnum Private m_LockTypeEnumDefault As DAO.LockTypeEnum -'Error-Events für mögliche Fehlerbehandlung über die FE-Anwendung -'/** -' -' Ereignis für fehlende CurrentDb-Referenz -' -' Meldung über Ursache der Ereignisauslösung. (Wird noch nicht genutzt) -' DAO.Database-Referenz, die für CurrentDb verwendet werden soll -' über den ByRef-Parameter NewCurrentDbRef kann die passende DAO.Database-Referenz weitergegeben werden. -'**/ +'############################################################# +' Group: Events + +'--------------------------------------------------------------------------------------- +' Event: ErrorMissingCurrentDb +'--------------------------------------------------------------------------------------- +' Event for missing CurrentDb reference +' +' Parameters: +' Msg - Message about the cause of the event triggering. (Not yet used) +' NewCurrentDbRef - DAO.Database reference to be used for CurrentDb +' +' Remarks: +' The required DAO.Database reference can be passed on via the ByRef parameter NewCurrentDbRef. +' +'--------------------------------------------------------------------------------------- Public Event ErrorMissingCurrentDb(ByVal Msg As String, ByRef NewCurrentDbRef As DAO.Database) + +'############################################################# +' Group: Class control + ' ' Init / Terminate ' ---------------- @@ -68,6 +79,13 @@ Private Sub Class_Terminate() Dispose End Sub +'--------------------------------------------------------------------------------------- +' Sub: Dispose +'--------------------------------------------------------------------------------------- +' +' Remove object references +' +'--------------------------------------------------------------------------------------- Public Sub Dispose() Set m_DaoDb = Nothing m_RecordsetTypeEnumDefault = 0 @@ -78,15 +96,17 @@ End Sub '--------------------------------------------------------------------------------------- ' Sub: InitRecordsetEnumDefaultValues '--------------------------------------------------------------------------------------- -'/** -' -' Standardwerte für Recordset-Enums einstellen, welche verwendet werden, wenn Parameter nicht gesetzt werden können (z. B. in OpenRecordsetParamSQL2) -' -' Standardwert aus DAO.RecordsetTypeEnum -' Standardwert aus DAO.RecordsetOptionEnum -' Standardwert aus DAO.LockTypeEnum -' Wenn 0 eingestellt wird, kommt Standard von DAO zum Einsatz (0-Parameter werden als "IsMissing"-Variant-Wert an DAO weitergeben) -'**/ +' +' Set default values for recordset enums, which are used when parameters cannot be set. +' +' Parameters: +' RecordsetType - DAO.RecordsetTypeEnum +' Options - DAO.RecordsetOptionEnum +' LockEdit - DAO.LockTypeEnum +' +' Remarks: +' If 0 is set, standard of DAO is used (0 parameters are passed on to DAO as "IsMissing" variant value). +' '--------------------------------------------------------------------------------------- Public Sub InitRecordsetEnumDefaultValues( _ Optional ByRef RecordsetType As DAO.RecordsetTypeEnum, _ @@ -99,33 +119,36 @@ Public Sub InitRecordsetEnumDefaultValues( _ End Sub +'############################################################# +' Group: Data Connection + '--------------------------------------------------------------------------------------- ' Property: CurrentDb '--------------------------------------------------------------------------------------- -'/** -' -' CurrentDbC-Variante -' -' DAO.Database -' -' CurrentDbC-Variante, die zum Unterschied zur Original-Version von Michael Kaplan -' die DAO-Database-Referenz nicht automatisch auf Access.Application.CurrentDb setzt, -' sondern über ein Ereignis anfordert, falls noch keine Referenz vorhanden ist. -' Dadurch kann über die Hauptanwendung eine belibige Database-Referenz übergeben werden. -' (z. B. falls eine Temp-Datenbank als CurrentDb dienen soll) -'**/ +' +' CurrentDbC variant +' +' Returns: +' DAO.Database +' +' Remarks: +' CurrentDbC variant which, unlike the original version by Michael Kaplan, +' does not automatically set the DAO database reference to Access.Application.CurrentDb, +' but requests it via an event if no reference exists yet. +' This allows any database reference to be passed via the main application. +' (e.g. if a temp database is to serve as CurrentDb). +' '--------------------------------------------------------------------------------------- Public Property Get CurrentDb() As DAO.Database If (m_DaoDb Is Nothing) Then 'Error-Event auslösen und hoffen, dass neue Referenz geliefert wird RaiseEvent ErrorMissingCurrentDb("DaoHandler.CurrentDb: unavailable CurrentDb-Database", m_DaoDb) If (m_DaoDb Is Nothing) Then - 'CurrentDb der Anwendung verwenden, falls DaoHandler "selbstinstanzierend" (VB_PredeclaredId = True) verwendet wird - ' Achtung! ... diese Prüfung hat eventuell den Nachteil, - ' dass ab hier VB_PredeclaredId wirksam wird, - ' obwohl es möglicherweise nicht benötigt wird. - If Me Is DaoHandler Then 'trifft nur zu, wenn Instanz identisch mit der VB_PredeclaredId-Instanz ist - ' Jede andere Instanz von DaoHandler hat andere Speicheradresse (ObjPtr(Me) <> ObjPtr(DaoHandler)). + 'Use CurrentDb of the application if DaoHandler "self-instantiating" (VB_PredeclaredId = True) is used. + 'Attention! ... this check may have the disadvantage that from here on VB_PredeclaredId takes effect, + ' although it may not be needed. + If Me Is DaoHandler Then 'applies only if instance is identical to VB_PredeclaredId instance + ' Every other instance of DaoHandler has different memory address (ObjPtr(Me) <> ObjPtr(DaoHandler)). Set Me.CurrentDb = Application.CurrentDb End If End If @@ -133,37 +156,30 @@ Public Property Get CurrentDb() As DAO.Database Set CurrentDb = m_DaoDb End Property +Public Property Set CurrentDb(ByRef NewCurrentDb As DAO.Database) + Set m_DaoDb = NewCurrentDb +End Property + Friend Property Get CurrentDbReferenceOnly() As DAO.Database Set CurrentDbReferenceOnly = m_DaoDb End Property -'--------------------------------------------------------------------------------------- -' Property: CurrentDb -'--------------------------------------------------------------------------------------- -'/** -' -' Übergabe der DAO-Database-Referenz -' -' Database-Referenz, die als "CurrentDb" verwendet werden soll -' DAO.Database -' -'**/ -'--------------------------------------------------------------------------------------- -Public Property Set CurrentDb(ByRef NewCurrentDb As DAO.Database) - Set m_DaoDb = NewCurrentDb -End Property +'############################################################# +' Group: Data Operations '--------------------------------------------------------------------------------------- ' Function: Execute '--------------------------------------------------------------------------------------- -'/** -' -' SQL-Anweisung ausführen -' -' SQL-Anweisung -' -' Long (Anzahl der betroffenen Datensätze) -'**/ +' +' Execute SQL statement +' +' Parameters: +' CommandText - SQL statement (String) +' Options - DAO.RecordsetOptionEnum +' +' Returns: +' RecordsAffected (Long) +' '--------------------------------------------------------------------------------------- Public Function Execute(ByVal Query As String, _ Optional ByVal Options As DAO.RecordsetOptionEnum) As Long @@ -179,21 +195,16 @@ End Function '--------------------------------------------------------------------------------------- ' Function: ExecuteParamSQL '--------------------------------------------------------------------------------------- -'/** -' -' Sql-Anweisung mit Parametern ausführen -' -' SQL-Anweisung -' Parmeterwerte in passender Reihenfolge -' -' Werte in passender Reihenfolge als ParamArray oder als Array
-' oder
-' 2-dimensionales Parameter-Array (Array(n,1) ... x(n,0) = Parametername, x(n,1) = Parameterwert) ... erzeugbar mit GetParamDefArray oder GetNamedParamDefArray -' -' Long (Anzahl der betroffenen Datensätze) -' -' -'**/ +' +' Execute SQL statement with parameters +' +' Parameters: +' SqlText - SQL statement +' QueryParams - Values in suitable order as ParamArray or as array or 2-dimensional parameter array (Array(n,1) ... x(n,0) = parameter name, x(n,1) = parameter value) ... generateable with GetParamDefArray or GetNamedParamDefArray +' +' Returns: +' RecordsAffected (Long) +' '--------------------------------------------------------------------------------------- Public Function ExecuteParamSql(ByVal SqlText As String, _ ParamArray QueryParams() As Variant) As Long @@ -230,20 +241,17 @@ End Function '--------------------------------------------------------------------------------------- ' Function: ExecuteQueryDefByName '--------------------------------------------------------------------------------------- -'/** -' -' Gespeicherte Abfrage (optional mit Parametern) ausführen -' -' Name der gespeicherten Abfrage (QueryDef) -' -' Werte in passender Reihenfolge als ParamArray oder als Array
-' oder
-' 2-dimensionales Parameter-Array (Array(n,1) ... x(n,0) = Parametername, x(n,1) = Parameterwert) ... erzeugbar mit GetParamDefArray oder GetNamedParamDefArray -' -' Long (Anzahl der betroffenen Datensätze) -' -' -'**/ +' +' Execute saved query (optionally with parameters) +' +' Parameters: +' QueryName - QueryDef name +' QueryParams - Values in suitable order as ParamArray or as array +' or 2-dimensional parameter array (Array(n,1) ... x(n,0) = parameter name, x(n,1) = parameter value) ... generateable with GetParamDefArray or GetNamedParamDefArray +' +' Returns: +' RecordsAffected (Long) +' '--------------------------------------------------------------------------------------- Public Function ExecuteQueryDefByName(ByVal QueryName As String, _ ParamArray QueryParams() As Variant) As Long @@ -280,20 +288,17 @@ End Function '--------------------------------------------------------------------------------------- ' Function: ExecuteQueryDef '--------------------------------------------------------------------------------------- -'/** -' -' QueryDef-Objekt mit Parameterwerten befüllen und anschließend ausführen -' -' QueryDef-Referenz -' -' Werte in passender Reihenfolge als ParamArray oder als Array
-' oder
-' 2-dimensionales Parameter-Array (Array(n,1) ... x(n,0) = Parametername, x(n,1) = Parameterwert) ... erzeugbar mit GetParamDefArray oder GetNamedParamDefArray -' -' Long (Anzahl der betroffenen Datensätze) -' -' -'**/ +' +' Fill QueryDef object with parameter values and then execute it +' +' Parameters: +' QdfRef - QueryDef reference +' QueryParams - Values in suitable order as ParamArray or as array +' or 2-dimensional parameter array (Array(n,1) ... x(n,0) = parameter name, x(n,1) = parameter value) ... generateable with GetParamDefArray or GetNamedParamDefArray +' +' Returns: +' RecordsAffected (Long) +' '--------------------------------------------------------------------------------------- Public Function ExecuteQueryDef(ByVal QdfRef As DAO.QueryDef, _ ParamArray QueryParams() As Variant) As Long @@ -333,20 +338,17 @@ End Sub '--------------------------------------------------------------------------------------- ' Function: ParamQueryDefByName '--------------------------------------------------------------------------------------- -'/** -' -' Gespeicherte Abfrage als QueryDef-Objekt ink. übergebenen Parameterwerten öffnen -' -' QueryDef-Name -' -' Werte in passender Reihenfolge als ParamArray oder als Array
-' oder
-' 2-dimensionales Parameter-Array (Array(n,1) ... x(n,0) = Parametername, x(n,1) = Parameterwert) ... erzeugbar mit GetParamDefArray oder GetNamedParamDefArray -' -' DAO.QueryDef -' -' -'**/ +' +' Open saved query as QueryDef object incl. passed parameter values +' +' Parameters: +' QueryName - name of query with parameters +' QueryParams - Values in suitable order as ParamArray or as array +' or 2-dimensional parameter array (Array(n,1) ... x(n,0) = parameter name, x(n,1) = parameter value) ... generateable with GetParamDefArray or GetNamedParamDefArray +' +' Returns: +' DAO.QueryDef +' '--------------------------------------------------------------------------------------- Public Function ParamQueryDefByName(ByVal QueryName As String, ParamArray QueryParams() As Variant) As DAO.QueryDef @@ -366,20 +368,17 @@ End Function '--------------------------------------------------------------------------------------- ' Function: ParamQueryDefSql '--------------------------------------------------------------------------------------- -'/** -' +' ' Temporäres QueryDef-Objekt ink. übergebenen Parameterwerten öffnen -' -' SQL-Anweisung für das temporäre QueryDef-Objekt -' -' Werte in passender Reihenfolge als ParamArray oder als Array
-' oder
-' 2-dimensionales Parameter-Array (Array(n,1) ... x(n,0) = Parametername, x(n,1) = Parameterwert) ... erzeugbar mit GetParamDefArray oder GetNamedParamDefArray -' -' DAO.QueryDef -' -' -'**/ +' +' Parameters: +' ParamSqlText - SQL statement for the temporary QueryDef object +' QueryParams - Values in suitable order as ParamArray or as array +' or 2-dimensional parameter array (Array(n,1) ... x(n,0) = parameter name, x(n,1) = parameter value) ... generateable with GetParamDefArray or GetNamedParamDefArray +' +' Returns: +' DAO.QueryDef +' '--------------------------------------------------------------------------------------- Public Function ParamQueryDefSql(ByVal ParamSqlText As String, ParamArray QueryParams() As Variant) As DAO.QueryDef @@ -396,21 +395,21 @@ Public Function ParamQueryDefSql(ByVal ParamSqlText As String, ParamArray QueryP End Function - '--------------------------------------------------------------------------------------- ' Function: OpenRecordset '--------------------------------------------------------------------------------------- -'/** -' -' Recordset öffnen -' -' SQL-Anweisung oder Tabllen- bzw. Abfragename -' DAO.RecordsetTypeEnum (Standard: dbOpenDynaset) -' DAO.RecordsetOptionEnum (Standard: dbSeeChanges) -' DAO.LockTypeEnum (Standard: dbOptimistic) -' DAO.Recordset -' -'**/ +' +' Open DAO.Recordset +' +' Parameters: +' Source - SQL statement or table or query name +' RecordsetType - DAO.RecordsetTypeEnum (Standard: dbOpenDynaset) +' RecordsetOptions - DAO.RecordsetOptionEnum (Standard: dbSeeChanges) +' LockEdit - DAO.LockTypeEnum (Standard: dbOptimistic) +' +' Returns: +' DAO.Recordset +' '--------------------------------------------------------------------------------------- Public Function OpenRecordset(ByVal Source As String, _ Optional ByVal RecordsetType As DAO.RecordsetTypeEnum = dbOpenDynaset, _ @@ -421,7 +420,7 @@ Public Function OpenRecordset(ByVal Source As String, _ RecordsetOptions = RecordsetOptions + dbSeeChanges End If - ' Replace0WithIsMissing ... damit IsMissing für Variant-Datentyp an Original-DAO-Openrecordset wirkt + ' Replace0WithIsMissing ... so that IsMissing for Variant data type works on original DAO openrecordset Set OpenRecordset = Me.CurrentDb.OpenRecordset(Source, _ Replace0WithIsMissing(RecordsetType), _ Replace0WithIsMissing(RecordsetOptions), _ @@ -444,22 +443,20 @@ End Function '--------------------------------------------------------------------------------------- ' Function: OpenRecordsetParamSQL '--------------------------------------------------------------------------------------- -'/** -' -' Parameter-SQL-Anweisung öffnen (verwendet temporäres QueryDef) -' -' SQL-Anweisung mit Parameter (Parameters-Deklaration) -' DAO.RecordsetTypeEnum (Standard: dbOpenDynaset) -' DAO.RecordsetOptionEnum (Standard: dbSeeChanges) -' DAO.LockTypeEnum (Standard: dbOptimistic) -' -' Werte in passender Reihenfolge als ParamArray oder als Array
-' oder
-' 2-dimensionales Parameter-Array (Array(n,1) ... x(n,0) = Parametername, x(n,1) = Parameterwert) ... erzeugbar mit GetParamDefArray oder GetNamedParamDefArray -' -' DAO.Recordset -' -'**/ +' +' Open parameter SQL statement (uses temporary QueryDef) +' +' Parameters: +' ParamSqlText - SQL statement with parameters (parameter declaration) +' RecordsetType - DAO.RecordsetTypeEnum (Standard: dbOpenDynaset) +' RecordsetOptions - DAO.RecordsetOptionEnum (Standard: dbSeeChanges) +' LockEdit - DAO.LockTypeEnum (Standard: dbOptimistic) +' QueryParams - Values in suitable order as ParamArray or as array +' or 2-dimensional parameter array (Array(n,1) ... x(n,0) = parameter name, x(n,1) = parameter value) ... generateable with GetParamDefArray or GetNamedParamDefArray +' +' Returns: +' DAO.Recordset +' '--------------------------------------------------------------------------------------- Public Function OpenRecordsetParamSql(ByVal ParamSqlText As String, _ ByVal RecordsetType As DAO.RecordsetTypeEnum, _ @@ -495,21 +492,19 @@ HandleErr: End Function '--------------------------------------------------------------------------------------- -' Function: OpenRecordsetParamSQL2 +' Function: OpenRecordsetParamSql2 '--------------------------------------------------------------------------------------- -'/** -' -' Parameter-SQL-Anweisung öffnen (wie OpenRecordsetParamSQL, nur mit Standardwerten für RecordsetType, RecordsetOptions u. LockEdit) -' -' SQL-Anweisung mit Parameter (Parameters-Deklaration) -' -' Werte in passender Reihenfolge als ParamArray oder als Array
-' oder
-' 2-dimensionales Parameter-Array (Array(n,1) ... x(n,0) = Parametername, x(n,1) = Parameterwert) ... erzeugbar mit GetParamDefArray oder GetNamedParamDefArray -' -' DAO.Recordset -' -'**/ +' +' Open parameter SQL statement (like OpenRecordsetParamSQL, but with default values for RecordsetType, RecordsetOptions and LockEdit) +' +' Parameters: +' ParamSqlText - SQL statement with parameters (parameter declaration) +' QueryParams - Values in suitable order as ParamArray or as array +' or 2-dimensional parameter array (Array(n,1) ... x(n,0) = parameter name, x(n,1) = parameter value) ... generateable with GetParamDefArray or GetNamedParamDefArray' +' +' Returns: +' DAO.Recordset +' '--------------------------------------------------------------------------------------- Public Function OpenRecordsetParamSql2(ByVal ParamSqlText As String, _ ParamArray QueryParams() As Variant) As DAO.Recordset @@ -523,14 +518,15 @@ End Function '--------------------------------------------------------------------------------------- ' Function: GetParamDefArray '--------------------------------------------------------------------------------------- -'/** -' -' Erezugt 2-dimensionalen Parameter-Array (z. B. für OpenRecordsetQueryDef) -' -' Parmeterwerte in passender Reihenfolge (ohne Index-Kennung!) -' DAO.Recordset -' -'**/ +' +' Creates 2-dimensional parameter array (e.g. for OpenRecordsetQueryDef) +' +' Parameters: +' ParamValues - Parmeter values in matching order (without index identifier!) +' +' Returns: +' Variant (Array) +' '--------------------------------------------------------------------------------------- Public Function GetParamDefArray(ParamArray ParamValues() As Variant) As Variant @@ -639,14 +635,15 @@ End Function '--------------------------------------------------------------------------------------- ' Function: GetNamedParamDefArray '--------------------------------------------------------------------------------------- -'/** -' -' Erzeugt 2-dimensionalen Parameter-Array (z. B. für OpenRecordsetQueryDef) -' -' Parameter-Paare: abwechselnd Parameter-Index und Parameter-Wert -' DAO.Recordset -' -'**/ +' +' Creates 2-dimensional parameter array (e.g. for OpenRecordsetQueryDef) +' +' Parameters: +' ParamValues - Parameter pairs: alternating parameter index and parameter value +' +' Returns: +' Variant (Array) +' '--------------------------------------------------------------------------------------- Public Function GetNamedParamDefArray(ParamArray ParamIndexAndValues() As Variant) As Variant @@ -681,19 +678,20 @@ End Function '--------------------------------------------------------------------------------------- ' Function: OpenRecordsetQueryDefByName '--------------------------------------------------------------------------------------- -'/** -' -' Recordset von gespeicherter Abfrage (optional mit Parametern) öffnen -' -' Name der gespeicherten Abfrage (QueryDef) -' 2-dimensionales Parameter-Array (Array(n,1) ... x(n,0) = Parametername, x(n,1) = Parameterwert) -' DAO.RecordsetTypeEnum (Standard: dbOpenDynaset) -' DAO.RecordsetOptionEnum (Standard: dbSeeChanges) -' DAO.LockTypeEnum (Standard: dbOptimistic) -' DAO.Recordset -' -' -'**/ +' +' Open recordset from saved query (optionally with parameters) +' +' Parameters: +' QueryName - Name of the saved query +' QueryParams - Values in suitable order as ParamArray or as array +' or 2-dimensional parameter array (Array(n,1) ... x(n,0) = parameter name, x(n,1) = parameter value) ... generateable with GetParamDefArray or GetNamedParamDefArray' +' RecordsetType - DAO.RecordsetTypeEnum (Standard: dbOpenDynaset) +' RecordsetOptions - DAO.RecordsetOptionEnum (Standard: dbSeeChanges) +' LockEdit - DAO.LockTypeEnum (Standard: dbOptimistic) +' +' Returns: +' DAO.Recordset +' '--------------------------------------------------------------------------------------- Public Function OpenRecordsetQueryDefByName(ByVal QueryName As String, _ Optional ByVal QueryParams As Variant, _ @@ -728,32 +726,33 @@ End Function '--------------------------------------------------------------------------------------- ' Function: OpenRecordsetQueryDef '--------------------------------------------------------------------------------------- -'/** -' +' ' Recordset von gespeicherter Abfrage (optional mit Parametern) öffnen -' -' QueryDef-Referenz -' 2-dimensionales Parameter-Array (Array(n,1) ... x(n,0) = Parametername, x(n,1) = Parameterwert) -' DAO.RecordsetTypeEnum (Standard: dbOpenDynaset) -' DAO.RecordsetOptionEnum (Standard: dbSeeChanges) -' DAO.LockTypeEnum (Standard: dbOptimistic) -' DAO.Recordset -' -' -'**/ +' +' Parameters: +' QdfRef - QueryDef reference +' QueryParams - Values in suitable order as ParamArray or as array +' or 2-dimensional parameter array (Array(n,1) ... x(n,0) = parameter name, x(n,1) = parameter value) ... generateable with GetParamDefArray or GetNamedParamDefArray' +' RecordsetType - DAO.RecordsetTypeEnum (Standard: dbOpenDynaset) +' RecordsetOptions - DAO.RecordsetOptionEnum (Standard: dbSeeChanges) +' LockEdit - DAO.LockTypeEnum (Standard: dbOptimistic) +' +' Returns: +' DAO.Recordset +' '--------------------------------------------------------------------------------------- Public Function OpenRecordsetQueryDef(ByVal QdfRef As DAO.QueryDef, _ - Optional ByVal QdfParamDefs As Variant, _ + Optional ByVal QueryParams As Variant, _ Optional ByVal RecordsetType As DAO.RecordsetTypeEnum, _ - Optional ByVal Options As DAO.RecordsetOptionEnum, _ + Optional ByVal RecordsetOptions As DAO.RecordsetOptionEnum, _ Optional ByVal LockEdit As DAO.LockTypeEnum) As DAO.Recordset - If Not IsMissing(QdfParamDefs) Then - FillQueryDefParameters QdfRef, QdfParamDefs + If Not IsMissing(QueryParams) Then + FillQueryDefParameters QdfRef, QueryParams End If Set OpenRecordsetQueryDef = QdfRef.OpenRecordset(Replace0WithIsMissing(RecordsetType), _ - Replace0WithIsMissing(Options), _ + Replace0WithIsMissing(RecordsetOptions), _ Replace0WithIsMissing(LockEdit)) End Function @@ -761,36 +760,41 @@ End Function '--------------------------------------------------------------------------------------- ' Function: LookupSQL '--------------------------------------------------------------------------------------- -'/** -' -' Lookup-Recordset-Ersatzfunktion für die Übergabe einer vollständigen SQL-Anweisung -' -' SQL-Anweisung -' Feldauswahl, falls nicht das erste Feld des Recordsets zurückgegeben werden soll -' Rückgabewert bei fehlendem Datensatz oder NULL-Feldwert (Standard: Null -' Variant -' Die SQL-Anweisung ist im Jet-SQL-Dialekt zu schreiben. -'**/ +' +' Lookup DAO.Recordset replacement function for DLookup (passing a SQL statement) +' +' Parameters: +' SqlText - SQL statement +' Index - Field selection if the first field of the recordset is not to be returned. +' The index is passed in the same way as DAO.Recordset.Fields(index). +' ValueIfNull - Return value if record is missing or data field value is Null (default: Null). +' +' Returns: +' Variant - Null, if SQL statement does not return a record. +' +' Remarks: +' The SQL statement must be written in the Jet/ACE SQL dialect. +' '--------------------------------------------------------------------------------------- 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 @@ -799,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 @@ -807,121 +811,180 @@ End Function '--------------------------------------------------------------------------------------- ' Function: Lookup '--------------------------------------------------------------------------------------- -'/** -' -' Lookup-Recordset-Ersatzfunktion -' -' Feldname oder berechneter Ausdruck (Select-Teil) -' Tabelle, Abfrage oder SQL-Ausdruck für Sub-Abfrage (FROM-Teil) -' Filter (WHERE-Teil) -' Variant -' -'**/ +' +' DAO.Recordset replacement function for DLookup +' +' Parameters: +' Expr - Field name or calculated expression (select part) +' Domain - Table, query or SQL expression for sub-query (FROM part) +' Criteria - (Optional) Criteria string (WHERE part) +' ValueIfNull - Return value if record is missing or data field value is Null (default: Null). +' +' Returns: +' Variant +' '--------------------------------------------------------------------------------------- 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 '--------------------------------------------------------------------------------------- ' Function: Count '--------------------------------------------------------------------------------------- -'/** -' -' DCount-Recordset-Ersatzfunktion -' -' Feldname oder berechneter Ausdruck (Select-Teil) -' Tabelle, Abfrage oder SQL-Ausdruck für Sub-Abfrage (FROM-Teil) -' Filter (WHERE-Teil) -' 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) +' +' DAO.Recordset replacement function for DCount +' +' Parameters: +' Expr - Field name or calculated expression (select part) +' Domain - Table, query or SQL expression for sub-query (FROM part) +' Criteria - (optional) Criteria string (WHERE part) +' +' Returns: +' Long +' +'--------------------------------------------------------------------------------------- +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 '--------------------------------------------------------------------------------------- ' Function: Max '--------------------------------------------------------------------------------------- -'/** -' -' DMax-Recordset-Ersatzfunktion -' -' Feldname oder berechneter Ausdruck (Select-Teil) -' Tabelle, Abfrage oder SQL-Ausdruck für Sub-Abfrage (FROM-Teil) -' Filter (WHERE-Teil) -' Variant -' -'**/ +' +' DAO.Recordset replacement function for DMax +' +' Parameters: +' Expr - Field name or calculated expression (select part) +' Domain - Table, query or SQL expression for sub-query (FROM part) +' Criteria - (Optional) Criteria string (WHERE part) +' +' Returns: +' Variant +' '--------------------------------------------------------------------------------------- Public Function Max(ByVal Expr As String, ByVal Domain As String, Optional ByVal Criteria As Variant) As Variant Max = Me.Lookup("Max(" & Expr & ")", Domain, Criteria) End Function '--------------------------------------------------------------------------------------- -' Function: DMin +' Function: Min '--------------------------------------------------------------------------------------- -'/** -' -' DMin-Recordset-Ersatzfunktion -' -' Feldname oder berechneter Ausdruck (Select-Teil) -' Tabelle, Abfrage oder SQL-Ausdruck für Sub-Abfrage (FROM-Teil) -' Filter (WHERE-Teil) -' Variant -' -'**/ +' +' DAO.Recordset replacement function for DMin +' +' Parameters: +' Expr - Field name or calculated expression (select part) +' Domain - Table, query or SQL expression for sub-query (FROM part) +' Criteria - (Optional) Criteria string (WHERE part) +' +' Returns: +' Variant +' '--------------------------------------------------------------------------------------- Public Function Min(ByVal Expr As String, ByVal Domain As String, Optional ByVal Criteria As Variant) As Variant Min = Me.Lookup("Min(" & Expr & ")", Domain, Criteria) End Function '--------------------------------------------------------------------------------------- -' Function: DSum +' Function: Sum '--------------------------------------------------------------------------------------- -'/** -' -' DSum-Recordset-Ersatzfunktion -' -' Feldname oder berechneter Ausdruck (Select-Teil) -' Tabelle, Abfrage oder SQL-Ausdruck für Sub-Abfrage (FROM-Teil) -' Filter (WHERE-Teil) -' Variant -' -'**/ +' +' DAO.Recordset replacement function for DSum +' +' Parameters: +' Expr - Field name or calculated expression (select part) +' Domain - Table, query or SQL expression for sub-query (FROM part) +' Criteria - (Optional) Criteria string (WHERE part) +' +' Returns: +' Variant +' '--------------------------------------------------------------------------------------- Public Function Sum(ByVal Expr As String, ByVal Domain As String, Optional ByVal Criteria As Variant) As Variant Sum = Me.Lookup("Sum(" & Expr & ")", Domain, Criteria) End Function +'--------------------------------------------------------------------------------------- +' Function: Exists +'--------------------------------------------------------------------------------------- +' +' Check if record exists +' +' Parameters: +' Domain - data source (FROM part) +' Criteria - (Optional) Criteria string (WHERE part) +' +' Returns: +' Boolean +' +'--------------------------------------------------------------------------------------- +Public Function Exists(ByVal Domain As String, _ + Optional ByVal Criteria As String = vbNullString) As Boolean + + Dim strSQL As String + + strSQL = "SELECT True FROM " & Domain + If Len(Criteria) > 0 Then + strSQL = strSQL & " WHERE " & Criteria + End If + Exists = (LookupSql(strSQL, , False) = True) + +End Function + '--------------------------------------------------------------------------------------- ' Function: InsertIdentityReturn '--------------------------------------------------------------------------------------- -'/** -' -' Insert-SQL-Anweisung ausführen und letzten Identity-Wert (Autowert) zurückgeben -' -' Insert-SQL-Anweisung (INSERT ...) -' Identity-Wert oder NULL falls kein Datensatz angefügt wurde -' -' Funktioniert erst ab Jet 4.0 (Access 2000) und ist vom DBMS abhängig. Bei MySQL-Tabellen wird z. B. 0 zurückgegeben. -' (Die ADODB-Variante dieser Methode ist bezüglich Einsatz für aktive DBMS besser geeignet.) -' -'**/ -'--------------------------------------------------------------------------------------- -Public Function InsertIdentityReturn(ByVal InsertSql As String) As Variant +' +' Execute insert SQL statement and return last identity value (auto value) +' +' Parameters: +' InsertSQL - Insert SQL statement +' +' Returns: +' Identity value or NULL if no record was appended +' +' Remarks: +' 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. +' ( is more suitable regarding use for active DBMS.) +'--------------------------------------------------------------------------------------- +Public Function InsertIdentityReturn(ByVal InsertSQL As String) As Variant Dim db As DAO.Database Dim rst As DAO.Recordset @@ -930,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 @@ -965,40 +1028,44 @@ End Function '--------------------------------------------------------------------------------------- ' Function: InsertValues '--------------------------------------------------------------------------------------- -'/** -' -' Recordset öffnen und Werte eines Datensatzes anfügen -' -' Anfüge-Datenquelle -' Auflistung: Feldname1, Wert1, Feldname2, Wert2, .. FeldnameN, WertN -' True, wenn vollständig durchgeführt -' -' Da ein Recordset zum Einfügen verwendet wird, erfolgt im Code keine Datentyp-Prüfung -> auf implizite Konvertierung achten. -' -'**/ -'--------------------------------------------------------------------------------------- -Public Function InsertValues(ByVal SqlSource As String, ParamArray FieldsAndValues() As Variant) As Boolean - InsertValues = InsertRecordValuesArrayReturnFieldValue(SqlSource, vbNullString, FieldsAndValues) +' +' Open recordset and append values +' +' Parameters: +' Source - Insert data source +' FieldsAndValues - ParamArray: "Field1", Value1, "Field2", Value2, .... +' +' Returns: +' True if fully executed +' +' Remarks: +' Since a recordset is used for insertion, there is no data type check in the code -> watch out for implicit conversion. +' +'--------------------------------------------------------------------------------------- +Public Function InsertValues(ByVal Source As String, ParamArray FieldsAndValues() As Variant) As Boolean + InsertValues = InsertRecordValuesArrayReturnFieldValue(Source, vbNullString, FieldsAndValues) End Function '--------------------------------------------------------------------------------------- ' Function: InsertValuesReturnFieldValue '--------------------------------------------------------------------------------------- -'/** -' -' Recordset öffnen und Werte eines Datensatzes anfügen, gibt Wert eine definierten Datenfeldes zurück -' -' Anfüge-Datenquelle -' Datenfeld für Wertrückgabe -' Auflistung: Feldname1, Wert1, Feldname2, Wert2, .. FeldnameN, WertN -' Wert aus Datenfeld -' -' Da ein Recordset zum Einfügen verwendet wird, erfolgt im Code keine Datentyp-Prüfung -> auf implizite Konvertierung achten. -' -'**/ -'--------------------------------------------------------------------------------------- -Public Function InsertValuesReturnFieldValue(ByVal SqlSource As String, ByVal ReturnFieldNameOrIndex As Variant, ParamArray FieldsAndValues() As Variant) As Variant - InsertValuesReturnFieldValue = InsertRecordValuesArrayReturnFieldValue(SqlSource, ReturnFieldNameOrIndex, FieldsAndValues) +' +' Ropen ecordset and append values, returns value of a defined data field +' +' Parameters: +' Source - Insert data source +' ReturnFieldNameOrIndex - Datenfeld für Wertrückgabe +' FieldsAndValues - ParamArray: "Field1", Value1, "Field2", Value2, .... +' +' Returns: +' Value from data field +' +' Remarks: +' Since a recordset is used for insertion, there is no data type check in the code -> watch out for implicit conversion. +' +'--------------------------------------------------------------------------------------- +Public Function InsertValuesReturnFieldValue(ByVal Source As String, ByVal ReturnFieldNameOrIndex As Variant, ParamArray FieldsAndValues() As Variant) As Variant + InsertValuesReturnFieldValue = InsertRecordValuesArrayReturnFieldValue(Source, ReturnFieldNameOrIndex, FieldsAndValues) End Function Private Function InsertRecordValuesArrayReturnFieldValue( _ @@ -1068,23 +1135,23 @@ End Function '--------------------------------------------------------------------------------------- ' Function: NewRecord '--------------------------------------------------------------------------------------- -'/** -' -' Datensatz über Recordset anfügen und Feldwerte einstellen. -' -' Datenquelle (Tabellenname oder SQL-Anweisung) -' Feldname, dessen Wert zurückgegeben werden soll (z. B. Autowert-Feld) -' Neue Daten ... abwechselnd: Feldname, Feldwert -' Wert aus ReturnFieldName, oder True/False, falls kein ReturnFieldName festgelegt wurde -' -' -'**/ +' +' Append record via recordset and set field values. +' +' Parameters: +' Source - Data source (table name or SQL statement) +' ReturnFieldName - Field name whose value is to be returned (e.g. autonumber field). +' FieldsAndValues - new data ... ParamArray: "Field1", Value1, "Field2", Value2, .... +' +' Returns: +' Value from ReturnFieldName, or True/False if no ReturnFieldName was specified. +' '--------------------------------------------------------------------------------------- Public Function NewRecord(ByVal Source As String, ByVal ReturnFieldName As String, _ - ParamArray DataParams() As Variant) As Variant + ParamArray FieldsAndValues() As Variant) As Variant Dim vA() As Variant - vA = ConvertParamArrayToVariantArray(DataParams) + vA = ConvertParamArrayToVariantArray(FieldsAndValues) NewRecord = NewRecord_FieldArray(Source, ReturnFieldName, vA) End Function @@ -1155,19 +1222,19 @@ End Function '--------------------------------------------------------------------------------------- ' Function: CopyRecord '--------------------------------------------------------------------------------------- -'/** -' -' Datensatz kopieren und einzelne Werte ändern -' -' Datenquelle (Tabellenname oder SQL-Anweisung) -' Datenfeld-Nr. ab der die Daten kopiert werden -' Datenfeld-Nr. ab bis zu der die kopiert werden. Ein negativer Wert zähle von hinten. -' Feldname, dessen Wert zurückgegeben werden soll (z. B. Autowert-Feld) -' zu ändernde Daten ... abwechselnd: Feldname, Feldwert -' Wert aus ReturnFieldName, oder True/False, falls kein ReturnFieldName festgelegt wurde -' -' -'**/ +' +' Copy data set and change individual values +' +' Parameters: +' Source - Data source (table name or SQL statement) +' StartFieldNumber - Data field number (=field index+1) from which the data is copied +' LastFieldNumber - Data field number (=field index+1) up to which the data are copied. A negative value counts from behind. +' ReturnFieldName - Field name whose value is to be returned (e.g. auto number field). +' DataToChange - data to be changed ... alternating: field name, field value - ParamArray: "Field1", Value1, "Field2", Value2, .... +' +' Returns: +' Value from ReturnFieldName, or True/False if no ReturnFieldName was specified. +' '--------------------------------------------------------------------------------------- Public Function CopyRecord(ByVal Source As String, _ ByVal StartFieldNumber As Long, ByVal LastFieldNumber As Long, _ @@ -1184,41 +1251,36 @@ End Function Private Function CopyRecord_FieldArray(ByVal Source As String, _ ByVal StartFieldNumber As Long, ByVal LastFieldNumber As Long, _ ByVal ReturnFieldName As String, ByRef DataToChange() As Variant) As Variant -'Datensätze kopieren -' SQLFilter.....SQL.Text (Auswahl des zu kopierenden DS, !Feldnamen müssen den Namen der Tabelle entsprechen !) -' StartFeldID...Ab welcher FeldNummer sollen Daten geändert werden (Anm. Autowert im DS nach vorne, dann ausklammern oder gleich in SQL nicht anführen -' ctlChange.....abwechselnd Feldname und zugehörigen Wert eingeben z.B. "UserID","Testperson" On Error GoTo HandleErr - Dim lngNum As Long, i As Long, iDS As Long, anz As Long - Dim strCtl() As Variant, valCtl() As Variant - Dim rst As DAO.Recordset - Dim lngLastCopyField As Long, dsAnz As Long, Start As Long - Dim fCopyVal() As Variant + Dim lngNum As Long, i As Long, iDS As Long, anz As Long + Dim strCtl() As Variant, valCtl() As Variant + Dim rst As DAO.Recordset + Dim lngLastCopyField As Long, dsAnz As Long, Start As Long + Dim fCopyVal() As Variant - 'Parameterübernahme - lngNum = UBound(DataToChange) + 1 - - anz = 0 - ReDim strCtl((lngNum \ 2) - 1) - ReDim valCtl((lngNum \ 2) - 1) + lngNum = UBound(DataToChange) + 1 - For i = 0 To (lngNum - 2) Step 2 - strCtl(anz) = DataToChange(i) - valCtl(anz) = DataToChange(i + 1) - anz = anz + 1 - Next i - - 'Recordsetobjekt öffnen - Set rst = OpenRecordset(Source, dbOpenDynaset) + anz = 0 + ReDim strCtl((lngNum \ 2) - 1) + ReDim valCtl((lngNum \ 2) - 1) + + For i = 0 To (lngNum - 2) Step 2 + strCtl(anz) = DataToChange(i) + valCtl(anz) = DataToChange(i + 1) + anz = anz + 1 + Next i - If rst.EOF And rst.BOF Then - rst.Close - Set rst = Nothing - CopyRecord_FieldArray = 0 - Exit Function - End If + 'Recordsetobjekt öffnen + Set rst = OpenRecordset(Source, dbOpenDynaset) + + If rst.EOF And rst.BOF Then + rst.Close + Set rst = Nothing + CopyRecord_FieldArray = 0 + Exit Function + End If With rst .MoveLast @@ -1287,43 +1349,45 @@ On Error Resume Next Set rst = Nothing End If On Error GoTo 0 - Err.Raise FncErrNr, "CopyRecord_FieldArray", FncErrDesc + Err.Raise FncErrNr, "DaoHandler.CopyRecord_FieldArray", FncErrDesc End Function '--------------------------------------------------------------------------------------- ' Function: CopyRecords '--------------------------------------------------------------------------------------- -'/** -' +' ' Recordset öffnen und Werte eines Datensatzes anfügen -' -' Anfüge-Datenquelle -' Datenfeld, ab dem kopiert werden soll (z. B. auf 1. Platz ist Autowert => ab 2 kopieren -' Datenfeld, bis zu dem kopiert werden soll. Soderfälle: 0 = bis zum Ende, negative Wert = ab hinten gezählt -' Auflistung der zu ändernden Felder inkl. deren Werte: Feldname1, Wert1, Feldname2, Wert2, .. FeldnameN, WertN -' True, wenn vollständig durchgeführt -' -' Da ein Recordset zum Einfügen verwendet wird, erfolgt im Code keine Datentyp-Prüfung -> auf implizite Konvertierung achten. -' -'**/ -'--------------------------------------------------------------------------------------- -Public Function CopyRecords(ByVal SqlSource As String, _ - ByVal StartFeldID As Long, ByVal LastFeldID As Long, _ - ParamArray UpdateFieldsAndValues() As Variant) As Variant +' +' Parameters: +' Source - Data source (table name or SQL statement) +' StartFieldNumber - Data field number (=field index+1) from which the data is copied +' LastFieldNumber - Data field number (=field index+1) up to which the data are copied. A negative value counts from behind. +' DataToChange - data to be changed ... alternating: field name, field value - ParamArray: "Field1", Value1, "Field2", Value2, .... +' +' Returns: +' Boolean - True if success +' +' Remarks: +' Since a recordset is used for insertion, there is no data type check in the code -> watch out for implicit conversion. +' +'--------------------------------------------------------------------------------------- +Public Function CopyRecords(ByVal Source As String, _ + ByVal StartFieldNumber As Long, ByVal LastFieldNumber As Long, _ + ParamArray DataToChange() As Variant) As Boolean Dim maxIdx As Long Dim vA() As Variant Dim i As Long - maxIdx = UBound(UpdateFieldsAndValues) + maxIdx = UBound(DataToChange) ReDim vA(maxIdx) For i = 0 To maxIdx - vA(i) = UpdateFieldsAndValues(i) + vA(i) = DataToChange(i) Next i - CopyRecords = CopyRecordsArrayReturnFieldValue(SqlSource, StartFeldID, LastFeldID, vbNullString, vA) + CopyRecords = CopyRecordsArrayReturnFieldValue(Source, StartFieldNumber, LastFieldNumber, vbNullString, vA) End Function @@ -1333,33 +1397,36 @@ End Function '/** ' ' Datensätze kopieren und Werte ändern -' -' Anfüge-Datenquelle -' Datenfeld, ab dem kopiert werden soll (z. B. auf 1. Platz ist Autowert => ab 2 kopieren -' Datenfeld, bis zu dem kopiert werden soll. Soderfälle: 0 = bis zum Ende, negative Wert = ab hinten gezählt -' Datenfeld für Wertrückgabe -' Auflistung der zu ändernden Felder inkl. deren Werte: Feldname1, Wert1, Feldname2, Wert2, .. FeldnameN, WertN -' Wert aus Datenfeld -' -' Da ein Recordset zum Einfügen verwendet wird, erfolgt im Code keine Datentyp-Prüfung -> auf implizite Konvertierung achten. -' -'**/ -'--------------------------------------------------------------------------------------- -Public Function CopyRecordsReturnFieldValue(ByVal SqlSource As String, _ - ByVal StartFeldID As Long, ByVal LastFeldID As Long, _ - ByVal ReturnField As String, _ - ParamArray UpdateFieldsAndValues() As Variant) As Variant +' +' Parameters: +' Source - Data source (table name or SQL statement) +' StartFieldNumber - Data field number (=field index+1) from which the data is copied +' LastFieldNumber - Data field number (=field index+1) up to which the data are copied. A negative value counts from behind. +' ReturnFieldName - Field name whose value is to be returned (e.g. auto number field). +' DataToChange - data to be changed ... alternating: field name, field value - ParamArray: "Field1", Value1, "Field2", Value2, .... +' +' Returns: +' Value from ReturnFieldName, or True/False if no ReturnFieldName was specified. +' +' Remarks: +' Since a recordset is used for insertion, there is no data type check in the code -> watch out for implicit conversion. +' +'--------------------------------------------------------------------------------------- +Public Function CopyRecordsReturnFieldValue(ByVal Source As String, _ + ByVal StartFieldNumber As Long, ByVal LastFieldNumber As Long, _ + ByVal ReturnFieldName As String, _ + ParamArray DataToChange() As Variant) As Variant Dim maxIdx As Long Dim vA() As Variant Dim i As Long - maxIdx = UBound(UpdateFieldsAndValues) + maxIdx = UBound(DataToChange) ReDim vA(maxIdx) For i = 0 To maxIdx - vA(i) = UpdateFieldsAndValues(i) + vA(i) = DataToChange(i) Next i - CopyRecordsReturnFieldValue = CopyRecordsArrayReturnFieldValue(SqlSource, StartFeldID, LastFeldID, ReturnField, vA) + CopyRecordsReturnFieldValue = CopyRecordsArrayReturnFieldValue(Source, StartFieldNumber, LastFieldNumber, ReturnFieldName, vA) End Function @@ -1369,89 +1436,86 @@ Private Function CopyRecordsArrayReturnFieldValue(ByVal SqlSource As String, _ On Error GoTo HandleErr - Dim lngNum As Long, lngAnz As Long, i As Long, iDS As Long, anz As Long - Dim strCtl() As Variant, valCtl() As Variant - Dim rst As Object - Dim lngLastCopyField As Long, dsAnz As Long, Start As Long - Dim CopyFieldsAndValues() As Variant - Dim ErrNo As Long, ErrDesc As String, ErrSource As String - - 'Parameterübernahme - lngNum = UBound(UpdateFieldsAndValues) - LBound(UpdateFieldsAndValues) + 1 - - anz = 0 - ReDim strCtl((lngNum \ 2) - 1) - ReDim valCtl((lngNum \ 2) - 1) + Dim lngNum As Long, lngAnz As Long, i As Long, iDS As Long, anz As Long + Dim strCtl() As Variant, valCtl() As Variant + Dim rst As Object + Dim lngLastCopyField As Long, dsAnz As Long, Start As Long + Dim CopyFieldsAndValues() As Variant + Dim ErrNo As Long, ErrDesc As String, ErrSource As String + + lngNum = UBound(UpdateFieldsAndValues) - LBound(UpdateFieldsAndValues) + 1 - For i = 0 To (lngNum - 2) Step 2 - strCtl(anz) = UpdateFieldsAndValues(i) - valCtl(anz) = UpdateFieldsAndValues(i + 1) - anz = anz + 1 - Next i + anz = 0 + ReDim strCtl((lngNum \ 2) - 1) + ReDim valCtl((lngNum \ 2) - 1) - 'Recordsetobjekt öffnen - Set rst = Me.OpenRecordset(SqlSource, dbOpenDynaset) + For i = 0 To (lngNum - 2) Step 2 + strCtl(anz) = UpdateFieldsAndValues(i) + valCtl(anz) = UpdateFieldsAndValues(i + 1) + anz = anz + 1 + Next i - If rst.EOF And rst.BOF Then - rst.Close - Set rst = Nothing - CopyRecordsArrayReturnFieldValue = 0 - Exit Function - End If + Set rst = Me.OpenRecordset(SqlSource, dbOpenDynaset) - With rst - .MoveLast - .MoveFirst - dsAnz = .RecordCount - - If LastFeldID = 0 Then - lngLastCopyField = .Fields.Count - ElseIf LastFeldID < 0 Then - lngLastCopyField = .Fields.Count + LastFeldID - Else - lngLastCopyField = LastFeldID - End If - - ReDim CopyFieldsAndValues(dsAnz, lngLastCopyField) - - If StartFeldID > 1 Then Start = StartFeldID - 1 Else Start = 0 - - 'Werte einlesen - iDS = 0 - While Not .EOF - For i = Start To lngLastCopyField - 1 - If .Fields(i).Type <> dbBinary Then - CopyFieldsAndValues(iDS, i) = .Fields(i).Value - End If - Next i - .MoveNext - iDS = iDS + 1 - Wend - .MoveLast - - 'Werte kopieren - For iDS = 0 To (dsAnz - 1) - 'neuen DS anfügen - .AddNew - For i = Start To (lngLastCopyField - 1) - If .Fields(i).Type <> dbBinary Then - .Fields(i) = CopyFieldsAndValues(iDS, i) - End If - Next i - For i = 0 To (anz - 1) - .Fields(strCtl(i)) = valCtl(i) - Next i - .Update - Next iDS - - If Len(ReturnField & vbNullString) > 0 Then - .Bookmark = .LastModified - CopyRecordsArrayReturnFieldValue = .Fields(ReturnField) - Else - CopyRecordsArrayReturnFieldValue = True - End If - .Close - End With + If rst.EOF And rst.BOF Then + rst.Close + Set rst = Nothing + CopyRecordsArrayReturnFieldValue = 0 + Exit Function + End If + + With rst + .MoveLast + .MoveFirst + dsAnz = .RecordCount + + If LastFeldID = 0 Then + lngLastCopyField = .Fields.Count + ElseIf LastFeldID < 0 Then + lngLastCopyField = .Fields.Count + LastFeldID + Else + lngLastCopyField = LastFeldID + End If + + ReDim CopyFieldsAndValues(dsAnz, lngLastCopyField) + + If StartFeldID > 1 Then Start = StartFeldID - 1 Else Start = 0 + + 'Read values + iDS = 0 + While Not .EOF + For i = Start To lngLastCopyField - 1 + If .Fields(i).Type <> dbBinary Then + CopyFieldsAndValues(iDS, i) = .Fields(i).Value + End If + Next i + .MoveNext + iDS = iDS + 1 + Wend + .MoveLast + + 'Copy values + For iDS = 0 To (dsAnz - 1) + .AddNew + For i = Start To (lngLastCopyField - 1) + If .Fields(i).Type <> dbBinary Then + .Fields(i) = CopyFieldsAndValues(iDS, i) + End If + Next i + For i = 0 To (anz - 1) + .Fields(strCtl(i)) = valCtl(i) + Next i + .Update + Next iDS + + If Len(ReturnField & vbNullString) > 0 Then + .Bookmark = .LastModified + CopyRecordsArrayReturnFieldValue = .Fields(ReturnField) + Else + CopyRecordsArrayReturnFieldValue = True + End If + .Close + End With ExitHere: Set rst = Nothing diff --git a/access-add-in/source/codelib/data/dao/DaoTools.bas b/access-add-in/source/codelib/data/dao/DaoTools.bas index d260dd9..f9b3bc0 100644 --- a/access-add-in/source/codelib/data/dao/DaoTools.bas +++ b/access-add-in/source/codelib/data/dao/DaoTools.bas @@ -1,17 +1,16 @@ Attribute VB_Name = "DaoTools" Attribute VB_Description = "Hilfsfunktionen für den Umgang mit DAO" '--------------------------------------------------------------------------------------- -' Module: DaoTools +' Package: data.dao.DaoTools '--------------------------------------------------------------------------------------- -'/** -' \author Josef Poetzl -' -' Hilfsfunktionen für den Umgang mit DAO -' -' -' -'\ingroup data_dao -'**/ +' +' Auxiliary functions for the handling of DAO +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + '--------------------------------------------------------------------------------------- ' ' data/dao/DaoTools.bas @@ -42,9 +41,9 @@ 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 '--------------------------------------------------------------------------------------- @@ -65,7 +64,7 @@ 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, _ diff --git a/access-add-in/source/codelib/file/FileTools.bas b/access-add-in/source/codelib/file/FileTools.bas index 21f964f..b12fcdd 100644 --- a/access-add-in/source/codelib/file/FileTools.bas +++ b/access-add-in/source/codelib/file/FileTools.bas @@ -1,15 +1,16 @@ Attribute VB_Name = "FileTools" Attribute VB_Description = "Funktionen für Dateioperationen" '--------------------------------------------------------------------------------------- -' Module: FileTools +' Package: file.FileTools '--------------------------------------------------------------------------------------- -'/** -'\author Josef Poetzl -'\short Funktionen für Dateioperationen -' -' -'\ingroup file -'**/ +' +' File operation functions +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + '--------------------------------------------------------------------------------------- ' ' file/FileTools.bas @@ -22,9 +23,17 @@ Option Compare Text Option Explicit 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 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 FILTERSTRING_ALL_FILES As String = "All Files (*.*)" +#End If Private Const DEFAULT_TEMPPATH_NOENV As String = "C:\" Private Const PATHLEN_MAX As Long = 255 @@ -32,6 +41,8 @@ Private Const PATHLEN_MAX As Long = 255 Private Const SE_ERR_NOTFOUND As Long = 2 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" ( _ @@ -83,23 +94,23 @@ Private Declare Function API_ShellExecuteA Lib "shell32.dll" ( _ '--------------------------------------------------------------------------------------- ' Function: SelectFile '--------------------------------------------------------------------------------------- -'/** -' -' Datei mittels Dialog auswählen -' -' Startverzeichnis -' Dialogtitel -' Filterwerten - Beispiel: "(*.*)" oder "Alle (*.*)|Textdateien (*.txt)|Bilder (*.png;*.jpg;*.gif) -' Mehrfachauswahl -' Anzeigeart (0: Detailansicht, 1: Vorschauansicht, 2: Eigenschaften, 3: Liste, 4: Miniaturansicht, 5: Große Symbole, 6: Kleine Symbole) -' String (bei Mehfachauswahl sind die Dateien durch chr(9) getrennt) -' -' -'**/ +' +' Select file using dialogue +' +' Parameters: +' InitDir - Initial Folder +' DlgTitle - Title of dialogue +' FilterString - Filter settings - Example: "(*.*)" oder "All (*.*)|text files (*.txt)|Images (*.png;*.jpg;*.gif) +' MultiSelect - Multi-selection +' ViewMode - View mode (0: Detail view, 1: Preview, 2: Properties, 3: List, 4: Thumbnail, 5: Large symbols, 6: Small symbols) +' +' Returns: +' String - in case of multiple selection, the files are separated by chr(9)) +' '--------------------------------------------------------------------------------------- Public Function SelectFile(Optional ByVal InitialDir As String = vbNullString, _ Optional ByVal DlgTitle As String = SELECTBOX_FILE_DIALOG_TITLE, _ - Optional ByVal FilterString As String = "Alle Dateien (*.*)", _ + Optional ByVal FilterString As String = FILTERSTRING_ALL_FILES, _ Optional ByVal MultiSelectEnabled As Boolean = False, _ Optional ByVal ViewMode As Long = -1) As String @@ -110,19 +121,19 @@ End Function '--------------------------------------------------------------------------------------- ' Function: SelectFolder '--------------------------------------------------------------------------------------- -'/** -' -' Auswahldialog zur Verzeichnisauswahl -' -' Startverzeichnis -' Dialogtitel -' Filterwerten - Beispiel: "(*.*)" oder "Alle (*.*)|Textdateien (*.txt)|Bilder (*.png;*.jpg;*.gif) -' Mehrfachauswahl -' Anzeigeart (0: Detailansicht, 1: Vorschauansicht, 2: Eigenschaften, 3: Liste, 4: Miniaturansicht, 5: Große Symbole, 6: Kleine Symbole) -' String (bei Mehfachauswahl sind die Dateien durch chr(9) getrennt) -' -' -'**/ +' +' Folder selection dialogue +' +' Parameters: +' InitDir - Initial Folder +' DlgTitle - Title of dialogue +' FilterString - Filter settings, Default:* +' MultiSelect - Multi-selection +' ViewMode - View mode (0: Detail view, 1: Preview, 2: Properties, 3: List, 4: Thumbnail, 5: Large symbols, 6: Small symbols) +' +' Returns: +' String - in case of multiple selection, folders are separated by chr(9)) +' '--------------------------------------------------------------------------------------- Public Function SelectFolder(Optional ByVal InitialDir As String = vbNullString, _ Optional ByVal DlgTitle As String = SELECTBOX_FOLDER_DIALOG_TITLE, _ @@ -145,7 +156,7 @@ Private Function WizHook_GetFileName( _ Optional ByVal SelectFolderFlag As Boolean = False, _ Optional ByVal AppName As String) As String -'Zusammenfassung der Parameter von WizHook.GetFileName: http://www.team-moeller.de/?Tipps_und_Tricks:Wizhook-Objekt:GetFileName +'Summary of WizHook.GetFileName parameters: http://www.team-moeller.de/?Tipps_und_Tricks:Wizhook-Objekt:GetFileName 'View 0: Detailansicht ' 1: Vorschauansicht ' 2: Eigenschaften @@ -191,16 +202,16 @@ End Function '--------------------------------------------------------------------------------------- ' Function: UNCPath '--------------------------------------------------------------------------------------- -'/** -' -' Gibt den UNC-Pfad zurück -' -' Pfadangabe -' Fehler von API ignorieren -' String -' -' -'**/ +' +' Returns the UNC path +' +' Parameters: +' Path - Path to convert +' IgnoreErrors - true = ignore API errors +' +' Returns: +' String +' '--------------------------------------------------------------------------------------- Public Function UncPath(ByVal Path As String, Optional ByVal IgnoreErrors As Boolean = True) As String @@ -210,7 +221,6 @@ Public Function UncPath(ByVal Path As String, Optional ByVal IgnoreErrors As Boo If WNetGetConnection(VBA.Left$(Path, 2), UNC, VBA.Len(UNC)) Then - ' API-Routine gibt Fehler zurück: If IgnoreErrors Then UncPath = Path Else @@ -218,8 +228,7 @@ Public Function UncPath(ByVal Path As String, Optional ByVal IgnoreErrors As Boo End If Else - - ' Ergebnis zurückgeben: + UncPath = VBA.Left$(UNC, VBA.InStr(UNC, vbNullChar) - 1) & VBA.Mid$(Path, 3) End If @@ -229,15 +238,15 @@ End Function '--------------------------------------------------------------------------------------- ' Property: TempPath '--------------------------------------------------------------------------------------- -'/** -' -' Temp-Verzeichnis ermitteln -' -' String -' -' Verwendet API GetTempPathA -' -'**/ +' +' Determine Temp folder +' +' Returns: +' String +' +' Remarks: +' Uses API GetTempPathA +' '--------------------------------------------------------------------------------------- Public Property Get TempPath() As String @@ -253,6 +262,21 @@ Public Property Get TempPath() As String End Property +'--------------------------------------------------------------------------------------- +' Function: GetNewTempFileName +'--------------------------------------------------------------------------------------- +' +' Generate temporary file name +' +' Parameters: +' PathToUse +' FilePrefix +' FileExtension +' +' Returns: +' String +' +'--------------------------------------------------------------------------------------- Public Function GetNewTempFileName(Optional ByVal PathToUse As String = "", _ Optional ByVal FilePrefix As String = "", _ Optional ByVal FileExtension As String = "") As String @@ -268,14 +292,13 @@ Public Function GetNewTempFileName(Optional ByVal PathToUse As String = "", _ NewTempFileName = Left$(NewTempFileName, InStr(NewTempFileName, Chr$(0)) - 1) - 'Datei wieder löschen, da nur Name benötigt wird + 'Delete file, as only name is needed Call Kill(NewTempFileName) If Len(FileExtension) > 0 Then 'Fileextension umschreiben NewTempFileName = Left$(NewTempFileName, Len(NewTempFileName) - 3) & FileExtension End If - 'eigentlich müsste man hier prüfen, ob Datei vorhanden ist. - + GetNewTempFileName = NewTempFileName End Function @@ -283,18 +306,20 @@ End Function '--------------------------------------------------------------------------------------- ' Function: ShortenFileName '--------------------------------------------------------------------------------------- -'/** -' -' Dateipfad auf n Zeichen kürzen -' -' Vollständiger Pfad -' gewünschte Länge -' String -' -' Hilfreich für die Anzeigen in schmalen Textfeldern \n -' Beispiel: C:\Programme\...\Verzeichnis\Dateiname.txt -' -'**/ +' +' Shorten file path to n characters +' +' Parameters: +' FullFileName - Full path +' MaxLen - required length +' +' Returns: +' String +' +' Remarks: +' Helpful for the displays in narrow textboxes +' Example: C:\Programms\...\Folder\File.txt +' '--------------------------------------------------------------------------------------- Public Function ShortenFileName(ByVal FullFileName As Variant, ByVal MaxLen As Long) As String @@ -327,15 +352,15 @@ End Function '--------------------------------------------------------------------------------------- ' Function: FileNameWithoutPath '--------------------------------------------------------------------------------------- -'/** -' -' Dateinamen aus vollständiger Pfadangabe extrahieren -' -' Dateiname inkl. Verzeichnis -' String -' -' -'**/ +' +' Extract file name from complete path specification +' +' Parameters: +' FullPath">File name incl. directory +' +' Returns: +' String +' '--------------------------------------------------------------------------------------- Public Function FileNameWithoutPath(ByVal FullPath As Variant) As String @@ -352,18 +377,65 @@ Public Function FileNameWithoutPath(ByVal FullPath As Variant) As String End Function +'--------------------------------------------------------------------------------------- +' Function: GetDirFromFullFileName +'--------------------------------------------------------------------------------------- +' +' Determines the directory from the complete path of a file. +' +' Parameters: +' FullFileName - complete file path +' +' Returns: +' String +' +'--------------------------------------------------------------------------------------- +Public Function GetDirFromFullFileName(ByVal FullFileName As String) As String + GetDirFromFullFileName = PathFromFullFileName(FullFileName) +End Function + +'--------------------------------------------------------------------------------------- +' Function: PathFromFullFileName +'--------------------------------------------------------------------------------------- +' +' Extract file path +' +' Parameters: +' FullFileName - complete file path +' +' Returns: +' String +' +'--------------------------------------------------------------------------------------- +Public Function PathFromFullFileName(ByVal FullFileName As Variant) As String + + Dim DirPath As String + Dim Pos As Long + + DirPath = FullFileName + Pos = InStrRev(DirPath, "\") + If Pos > 0 Then + DirPath = Left$(DirPath, Pos) + Else + DirPath = vbNullString + End If + + PathFromFullFileName = DirPath + +End Function + '--------------------------------------------------------------------------------------- ' Function: CreateDirectory '--------------------------------------------------------------------------------------- -'/** -' -' Erstelle ein Verzeichnis inkl. aller fehlenden übergeordneten Verzeichnisse -' -' Zu erstellendes Verzeichnis -' Boolean: True = Verzeichnis wurde erstellt -' -' -'**/ +' +' Creates a directory including all missing parent directories +' +' Parameters: +' FullPath - Directory to be created +' +' Returns: +' Boolean - True = directory/folder created +' '--------------------------------------------------------------------------------------- Public Function CreateDirectory(ByVal FullPath As String) As Boolean @@ -373,7 +445,7 @@ Public Function CreateDirectory(ByVal FullPath As String) As Boolean FullPath = VBA.Left$(FullPath, Len(FullPath) - 1) End If - If DirExists(FullPath) Then 'Verzeichnis ist bereits vorhanden + If DirExists(FullPath) Then CreateDirectory = False Exit Function End If @@ -399,15 +471,15 @@ End Sub '--------------------------------------------------------------------------------------- ' Function: FileExists '--------------------------------------------------------------------------------------- -'/** -' -' Prüft Existens einer Datei -' -' Vollständige Pfadangabe -' Boolean -' -' -'**/ +' +' Check: file exists +' +' Parameters: +' FullPath - Full path specification +' +' Returns: +' Boolean +' '--------------------------------------------------------------------------------------- Public Function FileExists(ByVal FullPath As String) As Boolean @@ -416,22 +488,22 @@ Public Function FileExists(ByVal FullPath As String) As Boolean Loop FileExists = (VBA.Len(VBA.Dir$(FullPath, vbReadOnly Or vbHidden Or vbSystem)) > 0) And (VBA.Len(FullPath) > 0) - VBA.Dir$ "\" ' Problemvermeidung: issue #109 + VBA.Dir$ "\" ' Avoiding error: issue #109 End Function '--------------------------------------------------------------------------------------- ' Function: DirExists '--------------------------------------------------------------------------------------- -'/** -' -' Prüft Existenz eines Verzeichnisses -' -' Vollständige Pfadangabe -' Boolean -' -' -'**/ +' +' Check: directory/folder exists +' +' Parameters: +' FullPath - Full path specification +' +' Returns: +' Boolean +' '--------------------------------------------------------------------------------------- Public Function DirExists(ByVal FullPath As String) As Boolean @@ -440,23 +512,25 @@ Public Function DirExists(ByVal FullPath As String) As Boolean End If DirExists = (VBA.Dir$(FullPath, vbDirectory Or vbReadOnly Or vbHidden Or vbSystem) = ".") - VBA.Dir$ "\" ' Problemvermeidung: issue #109 + VBA.Dir$ "\" ' Avoiding error: issue #109 End Function '--------------------------------------------------------------------------------------- ' Function: GetFileUpdateDate '--------------------------------------------------------------------------------------- -'/** -' -' Letztes Änderungsdatum einer Datei -' -' Vollständige Pfadangabe -' Variant -' -' Fehler von API-Funktion werden ignoriert -' -'**/ +' +' Last modified date of a file +' +' Parameters: +' FullFileName - Full path specification +' +' Returns: +' Variant +' +' Remarks: +' Errors from API function are ignored +' '--------------------------------------------------------------------------------------- Public Function GetFileUpdateDate(ByVal FullFileName As String) As Variant If FileExists(FullFileName) Then @@ -470,19 +544,21 @@ End Function '--------------------------------------------------------------------------------------- ' Function: ConvertStringToFileName '--------------------------------------------------------------------------------------- -'/** -' -' Erzeugt aus einer Zeichenkette einen Dateinamen (ersetzt Sonderzeichen) -' -' Ausgangsstring für Dateinamen -' Zeichen als Ersatz für Sonderzeichen -' Zeichen die mit ReplaceWith ersetzt werden -' Zeichen die entfernt werden -' String -' -' Sonderzeichen: ? * " / ' : ( ) -' -'**/ +' +' Creates a file name from a string (replaces special characters) +' +' Parameters: +' Text - Initial string for file names +' ReplaceWith - Characters as a substitute for special characters +' CharsToReplace - Characters that are replaced with ReplaceWith +' CharsToDelete - Characters that will be removed +' +' Returns: +' String +' +' Remarks: +' special characters: ? * " / ' : ( ) +' '--------------------------------------------------------------------------------------- Public Function ConvertStringToFileName(ByVal Text As String, _ Optional ByVal ReplaceWith As String = "_", _ @@ -509,18 +585,19 @@ End Function '--------------------------------------------------------------------------------------- ' Function: GetFullPathFromRelativPath '--------------------------------------------------------------------------------------- -'/** -' -' Erezugt aus relativer Pfadangabe und "Basisverzeichnis" eine vollständige Pfadangabe -' -' relativer Pfad -' Ausgangsverzeichnis -' String -' -' Beispiel: -' GetFullPathFromRelativPath("..\..\Test.txt", "C:\Programme\xxx\") => "C:\test.txt" -' -'**/ +' +' Creates a complete path specification from relative path specification and "base directory". +' +' Parameters: +' RelativPath">relative path +' BaseDir">Base directory +' +' Returns: +' String +' +' Example: +' GetFullPathFromRelativPath("..\..\Test.txt", "C:\Programms\xxx\") => "C:\test.txt" +' '--------------------------------------------------------------------------------------- Public Function GetFullPathFromRelativPath(ByVal RelativPath As String, _ ByVal BaseDir As String) As String @@ -565,22 +642,21 @@ End Function '--------------------------------------------------------------------------------------- ' Function: GetRelativPathFromFullPath '--------------------------------------------------------------------------------------- -'/** -' -' Erzeugt einen relativen Pfad aus vollständiger Pfadangabe und Ausgangsverzeichnis -' -' vollständiger Pfadangabe -' Ausgangsverzeichnis -' ".\" als Kennung für relativen Pfad ergänzen -' String -' -' Beispiel: -' -' GetRelativPathFromFullPath("C:\test.txt", "C:\Programme\xxx\", True) -' => ".\..\..\test.txt" -' -' -'**/ +' +' Creates a relative path from the complete path specification and source directory +' +' Parameters: +' FullPath - Full path specification +' BaseDir - Base directory +' RelativePrefix - Add ".\" as relative path identifier +' +' Returns: +' String +' +' Example: +' GetRelativPathFromFullPath("C:\test.txt", "C:\Programms\xxx\", True) +' => ".\..\..\test.txt" +' '--------------------------------------------------------------------------------------- Public Function GetRelativPathFromFullPath(ByVal FullPath As String, _ ByVal BaseDir As String, _ @@ -655,53 +731,19 @@ Private Function TryGetRelativPathWithDecreaseBaseDir(ByVal FullPath As String, End Function -'--------------------------------------------------------------------------------------- -' Function: GetDirFromFullFileName -'--------------------------------------------------------------------------------------- -'/** -' -' Ermittels aus vollständer Pfadangabe einer Datei das Verzeichnis -' -' vollständer Pfadangabe -' String -' -' -'**/ -'--------------------------------------------------------------------------------------- -Public Function GetDirFromFullFileName(ByVal FullFileName As String) As String - GetDirFromFullFileName = PathFromFullFileName(FullFileName) -End Function - -Public Function PathFromFullFileName(ByVal FullFileName As Variant) As String - - Dim DirPath As String - Dim Pos As Long - - DirPath = FullFileName - Pos = InStrRev(DirPath, "\") - If Pos > 0 Then - DirPath = Left$(DirPath, Pos) - Else - DirPath = vbNullString - End If - - PathFromFullFileName = DirPath - -End Function - '--------------------------------------------------------------------------------------- ' Sub: AddToZipFile '--------------------------------------------------------------------------------------- -'/** -' -' Datei an Zip-Datei anhängen. -' -' Zip-Datei -' Datei, die angehängt werden soll -' -' CreateObject("Shell.Application").Namespace(zipFile & "").CopyHere sFile & "" -' -'**/ +' +' Add file to Zip file +' +' Parameters: +' ZipFile - Zip file +' FullFileName - file to append +' +' Remarks: +' CreateObject("Shell.Application").Namespace(zipFile & "").CopyHere sFile & "" +' '--------------------------------------------------------------------------------------- Public Sub AddToZipFile(ByVal ZipFile As String, ByVal FullFileName As String) @@ -718,16 +760,16 @@ End Sub '--------------------------------------------------------------------------------------- ' Function: ExtractFromZipFile '--------------------------------------------------------------------------------------- -'/** -' -' Datei aus Zip-Datei extrahieren -' -' Zip-Datei -' Zielverzeichnis -' String -' -' -'**/ +' +' Extract file from zip file +' +' Parameters: +' ZipFile - Zip file +' Destination - Destination folder +' +' Returns: +' String +' '--------------------------------------------------------------------------------------- Public Function ExtractFromZipFile(ByVal ZipFile As String, ByVal Destination As String) As String @@ -741,16 +783,16 @@ End Function '--------------------------------------------------------------------------------------- ' Function: CreateZipFile '--------------------------------------------------------------------------------------- -'/** -' -' Erzeugt leere Zipdatei -' -' Zip-Datei -' Vorhandene Zip-Datei löschen -' Boolean -' -' -'**/ +' +' Creates an empty zip file +' +' Parameters: +' ZipFile - Zip file (full path) +' DeleteExistingFile - Delete existing Zip file +' +' Returns: +' Boolean +' '--------------------------------------------------------------------------------------- Public Function CreateZipFile(ByVal ZipFile As String, Optional ByRef DeleteExistingFile As Boolean = False) As Boolean @@ -777,59 +819,97 @@ End Function '--------------------------------------------------------------------------------------- ' Function: GetFileExtension '--------------------------------------------------------------------------------------- -'/** -' -' Gibt die Dateiendung einer Datei oder eines Pfads zurück. -' -' Dateipfad oder Dateiname -' Dateiendung inkl. Trennzeichen -' -' -'**/ +' +' Returns the file extension of a file returns. +' +' Parameters: +' FilePath - File path or file name +' WithDotBeforeExtension - True: returns extension excl. separator +' +' Returns: +' String - File extension +' '--------------------------------------------------------------------------------------- Public Function GetFileExtension(ByVal FilePath As String, Optional ByVal WithDotBeforeExtension As Boolean = False) As String GetFileExtension = VBA.Strings.Mid$(FilePath, VBA.Strings.InStrRev(FilePath, ".") + (1 - Abs(WithDotBeforeExtension))) End Function -Public Function OpenFile(FileName As String, Optional ByVal ReadOnlyMode As Boolean = False) As Boolean - Dim strFile As String +'--------------------------------------------------------------------------------------- +' Function: OpenFile +'--------------------------------------------------------------------------------------- +' +' Open file with API ShellExecute +' +' Parameters: +' FileName - File path or file name +' +' Returns: +' Boolean +' +'--------------------------------------------------------------------------------------- +Public Function OpenFile(ByVal FilePath As String, Optional ByVal ReadOnlyMode As Boolean = False) As Boolean + + Const FileNotFoundErrorTextTemplate As String = "File '{FilePath}' not found." + Dim FileNotFoundErrorText As String - strFile = FileName - If Len(Dir(strFile)) = 0 Then - Err.Raise vbObjectError, "OpenFile", "Die Datei '" & FileName & vbNewLine & "' " & _ - "konnte nicht gefunden werden." & vbNewLine & _ - "Bitte überprüfen Sie den Datei-Pfad." - Exit Function + If Len(VBA.Dir(FilePath)) = 0 Then + +#If USELOCALIZATION = 1 Then + FileNotFoundErrorText = Replace(L10n.Text(FileNotFoundErrorTextTemplate), "{FilePath}", FilePath) +#Else + FileNotFoundErrorText = Replace(FileNotFoundErrorTextTemplate, "{FilePath}", FilePath) +#End If + Err.Raise VbaErrNo_FileNotFound, "FileTools.OpenFile", FileNotFoundErrorText + Exit Function End If - OpenFile = ShellExecute(strFile, "open") + OpenFile = ShellExecute(FilePath, "open") End Function -Public Function OpenFilePath(FilePath As String) As Boolean +'--------------------------------------------------------------------------------------- +' Function: OpenFilePath +'--------------------------------------------------------------------------------------- +' +' Open folder with API ShellExecute +' +' Parameters: +' FilePath - folder path or file name +' +' Returns: +' Boolean +' +'--------------------------------------------------------------------------------------- +Public Function OpenFilePath(ByVal FolderPath As String) As Boolean - Dim strFile As String + Const FolderNotFoundErrorTextTemplate As String = "File '{FolderPath}' not found." + Dim FolderNotFoundErrorText As String - strFile = FilePath - If Len(Dir(FilePath, vbDirectory)) = 0 Then - Err.Raise vbObjectError, "OpenFilePath", "Das Verzeichnis '" & FilePath & vbNewLine & "' " & _ - "konnte nicht gefunden werden." & vbNewLine & _ - "Bitte überprüfen Sie den Pfad." - Exit Function + If Len(VBA.Dir(FolderPath, vbDirectory)) = 0 Then + +#If USELOCALIZATION = 1 Then + FolderNotFoundErrorText = Replace(L10n.Text(FolderNotFoundErrorTextTemplate), "{FolderPath}", FolderPath) +#Else + FolderNotFoundErrorText = Replace(FolderNotFoundErrorTextTemplate, "{FolderPath}", FolderPath) +#End If + Err.Raise VbaErrNo_FileNotFound, "FileTools.OpenFilePath", FolderNotFoundErrorText + Exit Function End If - OpenFilePath = ShellExecute(strFile, "open") + OpenFilePath = ShellExecute(FolderPath, "open") End Function Private Function ShellExecute(ByVal FilePath As String, _ - Optional ByVal ApiOperation As String = vbNullString) As Boolean + Optional ByVal ApiOperation As String = vbNullString) As Boolean + Const FileNotFoundErrorTextTemplate As String = "File '{FilePath}' not found." + Dim FileNotFoundErrorText As String Dim Ret As Long Dim Directory As String Dim DeskWin As Long - + If Len(FilePath) = 0 Then ShellExecute = False Exit Function @@ -839,9 +919,12 @@ Private Function ShellExecute(ByVal FilePath As String, _ End If If Ret = SE_ERR_NOTFOUND Then - 'Datei nicht gefunden - MsgBox "Datei nicht gefunden" & vbNewLine & vbNewLine & _ - FilePath +#If USELOCALIZATION = 1 Then + FileNotFoundErrorText = Replace(L10n.Text(FileNotFoundErrorTextTemplate), "{FilePath}", FilePath) +#Else + FileNotFoundErrorText = Replace(FileNotFoundErrorTextTemplate, "{FilePath}", FilePath) +#End If + Err.Raise VbaErrNo_FileNotFound, "FileTools.OpenFile", FileNotFoundErrorText ShellExecute = False Exit Function ElseIf Ret = SE_ERR_NOASSOC Then diff --git a/access-add-in/source/codelib/text/StringTools.bas b/access-add-in/source/codelib/text/StringTools.bas index 054f43e..3255050 100644 --- a/access-add-in/source/codelib/text/StringTools.bas +++ b/access-add-in/source/codelib/text/StringTools.bas @@ -1,16 +1,20 @@ Attribute VB_Name = "StringTools" Attribute VB_Description = "String-Hilfsfunktionen" '--------------------------------------------------------------------------------------- -' Modul: StringTools +' Package: text.StringTools '--------------------------------------------------------------------------------------- -'/** -' -' Text-Hilfsfunktionen -' -' ' -' \ingroup text -'**/ +' Text functions +' +' Author: +' Josef Poetzl, Sten Schmidt +' +' Remarks: +' Use DisableReplaceVbaStringFunctions = 1 in conditional compilation arguments (in vbe project properties) +' to disable replacement of VBA.Format function +' +'--------------------------------------------------------------------------------------- + '--------------------------------------------------------------------------------------- ' ' text/StringTools.bas @@ -26,16 +30,13 @@ Option Private Module '--------------------------------------------------------------------------------------- ' Enum: TrimOption '--------------------------------------------------------------------------------------- -'/** '<-- Start Doxygen-Block -' -' Verfügbare Trim-Optionen für die Trim-Funktion -' -' -' TrimStart (1)Führende Leerzeichen aus einer Zeichenfolgenvariablen entfernen -' TrimEnd (2)Nachgestellte Leerzeichen aus einer Zeichenfolgenvariablen entfernen -' TrimBoth (3)Führende und nachgestellte Leerzeichen entfernen -' -'**/ '<-- Ende Doxygen-Block +' +' Available trim options for the trim function +' +' TrimStart - (1) Remove leading spaces from a string variable +' TrimEnd - (2) Remove trailing spaces from a string variable +' TrimBoth - (3) Remove leading and trailing spaces +' '--------------------------------------------------------------------------------------- Public Enum TrimOption TrimStart = 1 @@ -46,15 +47,16 @@ End Enum '--------------------------------------------------------------------------------------- ' Function: IsNullOrEmpty '--------------------------------------------------------------------------------------- -'/** -' -' Gibt an, ob der übergebene Wert Null oder eine leere Zeichenfolge ist. -' -' Zu prüfender Wert -' Leerzeichen am Anfang u. Ende ignorieren -' Boolean -' -'**/ +' +' Specifies whether the passed value is null or an empty string +' +' Parameters: +' ValueToTest - Value to be checked +' IgnoreSpaces - Ignore spaces at the beginning and end +' +' Returns: +' Boolean +' '--------------------------------------------------------------------------------------- Public Function IsNullOrEmpty(ByVal ValueToTest As Variant, Optional ByVal IgnoreSpaces As Boolean = False) As Boolean @@ -78,15 +80,16 @@ End Function '--------------------------------------------------------------------------------------- ' Function: FormatText '--------------------------------------------------------------------------------------- -'/** -' -' Fügt in den Platzhalter des Formattextes die übergebenen Parameter ein -' -' Textformat mit Platzhalter ... Beispiel: "XYZ{0}, {1}" -' übergabeparameter in passender Reihenfolge -' String -' -'**/ +' +' Inserts the passed parameters into the placeholder {0..n} of the format text +' +' Parameters: +' FormatString - Text format with placeholder ... Example: "XYZ{0}, {1}" +' Args - Passing parameters in suitable order +' +' Returns: +' String +' '--------------------------------------------------------------------------------------- Public Function FormatText(ByVal FormatString As String, ParamArray Args() As Variant) As String @@ -111,23 +114,31 @@ End Function '--------------------------------------------------------------------------------------- ' Function: Format '--------------------------------------------------------------------------------------- -'/** -' -' Ersetzt die VBA-Formatfunktion -' Erweiterung: [h] bzw. [hh] für Stundenanzeige über 24 -' -' -' Ein gültiger benannter oder benutzerdefinierter Formatausdruck inkl. Erweiterung für Stundenanzeige über 24 (Standard-Formatanweisungen siehe VBA.Format) -' Wird an VBA.Format weitergereicht -' Wird an VBA.Format weitergereicht -' String -' -' -'**/ +' +' Replaces the VBA format function +' Extension: [h] or [hh] for hour display over 24 +' +' Parameters: +' Expression - The value to format +' FormatString - A valid named or user-defined format expression incl. extension for hours display over 24 (for standard format instructions see VBA.Format) +' FirstDayOfWeek - Passed on to VBA.Format +' FirstWeekOfYear - Passed on to VBA.Format +' +' Returns: +' 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 @@ -152,25 +163,27 @@ 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 '--------------------------------------------------------------------------------------- ' Function: PadLeft '--------------------------------------------------------------------------------------- -'/** -' -' Linksbündiges Auffüllen eines Strings -' -' String der augefüllt werden soll -' Gesamtlänge der resultierenen Zeichenfolge -' Zeichen mit dem aufgefüllt werden soll -' String -' -' Wenn die Länge von value größer oder gleich totalWidth ist, wird das Resultat auf totalWidth Zeichen begrenzt -' -'**/ +' +' Left padding of a string +' +' Parameters: +' Value - String to be filled in +' TotalWidth - Total length of the resulting string +' PadChar - (optional) Character to be padded with; Default: " " +' +' Returns: +' String +' +' Remarks: +' If the length of value is greater than or equal to totalWidth, the result is limited to totalWidth characters +' '--------------------------------------------------------------------------------------- Public Function PadLeft(ByVal Value As String, ByVal TotalWidth As Integer, Optional ByVal PadChar As String = " ") As String PadLeft = VBA.Right$(VBA.String$(TotalWidth, PadChar) & Value, TotalWidth) @@ -179,18 +192,20 @@ End Function '--------------------------------------------------------------------------------------- ' Function: PadRight '--------------------------------------------------------------------------------------- -'/** -' -' Rechtsbündiges Auffüllen eines Strings -' -' String der augefüllt werden soll -' Gesamtlänge der resultierenen Zeichenfolge -' Zeichen mit dem aufgefüllt werden soll -' String -' -' Wenn die Länge von Value größer oder gleich totalWidth ist, wird das Resultat auf TotalWidth Zeichen begrenzt -' -'**/ +' +' Right padding of a string +' +' Parameters: +' Value - String to be filled in +' TotalWidth - Total length of the resulting string +' PadChar - (optional) Character to be padded with; Default: " " +' +' Returns: +' String +' +' Remarks: +' If the length of value is greater than or equal to totalWidth, the result is limited to totalWidth characters +' '--------------------------------------------------------------------------------------- Public Function PadRight(ByVal Value As String, ByVal TotalWidth As Integer, Optional ByVal PadChar As String = " ") As String PadRight = VBA.Left$(Value & VBA.String$(TotalWidth, PadChar), TotalWidth) @@ -199,17 +214,19 @@ End Function '--------------------------------------------------------------------------------------- ' Function: Contains '--------------------------------------------------------------------------------------- -'/** -' -' Gibt an ob searchValue in der Zeichenfolge checkValue vorkommt. -' -' Zeichenfolge die durchsucht werden soll -' Zeichenfolge nach der gesucht werden soll -' Boolean -' -' Ergibt True, wenn searchValue in checkValue enthalten ist oder searchValue den Wert vbNullString hat -' -'**/ +' +' Indicates whether SearchValue occurs in the CheckValue string +' +' Parameters: +' CheckValue - String to be searched +' SearchValue - String to be searched for +' +' Returns: +' Boolean +' +' Remarks: +' Returns True if SearchValue is contained in CheckValue or SearchValue has the value vbNullString +' '--------------------------------------------------------------------------------------- Public Function Contains(ByVal CheckValue As String, ByVal SearchValue As String) As Boolean Contains = VBA.InStr(1, CheckValue, SearchValue, vbTextCompare) > 0 @@ -218,16 +235,16 @@ End Function '--------------------------------------------------------------------------------------- ' Function: EndsWith '--------------------------------------------------------------------------------------- -'/** -' -' Gibt an ob die Zeichenfolge CheckValue mit SearchValue endet. -' -' Zeichenfolge die durchsucht werden soll -' Zeichenfolge nach der gesucht werden soll -' Boolean -' -' -'**/ +' +' Indicates whether the string CheckValue ends with SearchValue +' +' Parameters: +' CheckValue - String to be searched +' SearchValue - String to be searched for +' +' Returns: +' Boolean +' '--------------------------------------------------------------------------------------- Public Function EndsWith(ByVal CheckValue As String, ByVal SearchValue As String) As Boolean EndsWith = VBA.Right$(CheckValue, VBA.Len(SearchValue)) = SearchValue @@ -236,16 +253,16 @@ End Function '--------------------------------------------------------------------------------------- ' Function: StartsWith '--------------------------------------------------------------------------------------- -'/** -' -' Gibt an ob die Zeichenfolge CheckValue mit SearchValue beginnt. -' -' Zeichenfolge die durchsucht werden soll -' Zeichenfolge nach der gesucht werden soll -' Boolean -' -' -'**/ +' +' Indicates whether the string CheckValue starts with SearchValue +' +' Parameters: +' CheckValue - String to be searched +' SearchValue - String to be searched for +' +' Returns: +' Boolean +' '--------------------------------------------------------------------------------------- Public Function StartsWith(ByVal CheckValue As String, ByVal SearchValue As String) As Boolean StartsWith = VBA.Left$(CheckValue, VBA.Len(SearchValue)) = SearchValue @@ -254,14 +271,15 @@ End Function '--------------------------------------------------------------------------------------- ' Function: Length '--------------------------------------------------------------------------------------- -'/** -' -' Gibt die Anzahl von Zeichen in Value zurück -' -' Anzahl Zeichen von Value als Long -' -' -'**/ +' +' Returns the number of characters in Value +' +' Parameters: +' Value - String to be checked +' +' Returns: +' Long - Anzahl Zeichen von Value +' '--------------------------------------------------------------------------------------- Public Function Length(ByVal Value As String) As Long Length = VBA.Len(Value) @@ -270,16 +288,16 @@ End Function '--------------------------------------------------------------------------------------- ' Function: Concat '--------------------------------------------------------------------------------------- -'/** -' -' Fügt der Zeichenfolge ValueA die Zeihenfolge ValueB an. -' -' Zeichenfolge -' Zeichenfolge -' ValueB angefügt an ValueA als String -' -' -'**/ +' +' Appends the string ValueB to the string ValueA. +' +' Parameters: +' ValueA - Base string +' ValueB - String to be append at end of A +' +' Returns: +' String - ValueB appended to ValueA +' '--------------------------------------------------------------------------------------- Public Function Concat(ByVal ValueA As String, ByVal ValueB As String) As String Concat = ValueA & ValueB @@ -288,17 +306,18 @@ End Function '--------------------------------------------------------------------------------------- ' Function: Trim '--------------------------------------------------------------------------------------- -'/** -' -' Entfernt führende und/oder nachfolgende Leerzeichen einer Zeichenfolge. -' Ersetzt die Funktion VBA.Trim(). -' -' Zeichenfolge -' Trim-Optionen -' String -' -' -'**/ +' +' Removes leading and/or trailing spaces from a string +' +' Replaces the function VBA.Trim(). +' +' Parameters: +' Value - String to be trimmed +' TrimType - Trim options (at start, at end or both) +' +' Returns: +' String +' '--------------------------------------------------------------------------------------- Public Function Trim(ByVal Value As String, Optional ByVal TrimType As TrimOption = TrimOption.TrimBoth) As String @@ -322,19 +341,20 @@ End Function '--------------------------------------------------------------------------------------- ' Function: Substring '--------------------------------------------------------------------------------------- -'/** -' -' Gibt einen Teil der Zeichenfolge Value zurück, die an der Position StartIndex beginnt -' und die Länge Length hat. -' -' Zeichenfolge -' Startposition in der Zeichenfolge -' Anzahl Zeichen die Zurückgegeben werden sollen -' String -' -' StartIndex ist Nullterminiert, analog zu String.Substring() in .NET -' -'**/ +' +' Returns a part of the string Value starting at the position StartIndex and having the length Length. +' +' Parameters: +' Value - String +' StartIndex - Start position in the string +' Length - Number of characters to be returned +' +' Returns: +' String +' +' Remarks: +' StartIndex is null terminated, analogous to String.Substring() in .NET +' '--------------------------------------------------------------------------------------- Public Function SubString(ByVal Value As String, ByVal StartIndex As Long, Optional ByVal Length As Long = 0) As String If Length = 0 Then Length = StringTools.Length(Value) - StartIndex @@ -344,17 +364,17 @@ End Function '--------------------------------------------------------------------------------------- ' Function: InsertAt '--------------------------------------------------------------------------------------- -'/** -' +' ' Setzt die Zeichenfolge InsertValue an der Position Pos ein -' -' Zeichenfolge -' Zeichenfolge die eingefügt werden soll -' Position an der die Zeichenfolge eingefügt werden soll (Pos ist nullterminiert) -' String -' -' -'**/ +' +' Parameters: +' Value - String +' InsertValue - String to be inserted +' Pos - Position at which the string is to be inserted (Pos is zero-terminated). +' +' Returns: +' String +' '--------------------------------------------------------------------------------------- Public Function InsertAt(ByVal Value As String, ByVal InsertValue As String, ByVal Pos As Long) As String InsertAt = VBA.Mid$(Value, 1, Pos) & InsertValue & StringTools.SubString(Value, Pos) @@ -363,17 +383,19 @@ End Function '--------------------------------------------------------------------------------------- ' Function: Replicate '--------------------------------------------------------------------------------------- -'/** -' -' Zeichenfolge wiederholen -' -' Die zu wiederholende Zeichenfolge -' Anzahl der Wiederholungen -' String -' -' Replicate("abc", 3) erzeugt "abcabcabc" -' -'**/ +' +' Repeat string +' +' Parameters: +' Value - The string to be repeated +' Number - Number of repetitions +' +' Returns: +' String +' +' Remarks: +' Replicate("abc", 3) creates "abcabcabc" +' '--------------------------------------------------------------------------------------- Public Function Replicate(ByVal Value As String, ByVal Number As Long) As String diff --git a/binaries/accunit/x64/AccessCodeLib.AccUnit.dll b/binaries/accunit/x64/AccessCodeLib.AccUnit.dll index 070746d..5cbafa6 100644 Binary files a/binaries/accunit/x64/AccessCodeLib.AccUnit.dll and b/binaries/accunit/x64/AccessCodeLib.AccUnit.dll differ diff --git a/binaries/accunit/x64/AccessCodeLib.AccUnit.tlb b/binaries/accunit/x64/AccessCodeLib.AccUnit.tlb index 551e050..de9911c 100644 Binary files a/binaries/accunit/x64/AccessCodeLib.AccUnit.tlb and b/binaries/accunit/x64/AccessCodeLib.AccUnit.tlb differ diff --git a/binaries/accunit/x64/AccessCodeLib.Common.VBIDETools.dll b/binaries/accunit/x64/AccessCodeLib.Common.VBIDETools.dll index 9146e84..94ca902 100644 Binary files a/binaries/accunit/x64/AccessCodeLib.Common.VBIDETools.dll and b/binaries/accunit/x64/AccessCodeLib.Common.VBIDETools.dll differ diff --git a/binaries/accunit/x86/AccessCodeLib.AccUnit.dll b/binaries/accunit/x86/AccessCodeLib.AccUnit.dll index 9bfb72f..555cd1b 100644 Binary files a/binaries/accunit/x86/AccessCodeLib.AccUnit.dll and b/binaries/accunit/x86/AccessCodeLib.AccUnit.dll differ diff --git a/binaries/accunit/x86/AccessCodeLib.AccUnit.tlb b/binaries/accunit/x86/AccessCodeLib.AccUnit.tlb index 15c8ae7..0f4879c 100644 Binary files a/binaries/accunit/x86/AccessCodeLib.AccUnit.tlb and b/binaries/accunit/x86/AccessCodeLib.AccUnit.tlb differ diff --git a/binaries/accunit/x86/AccessCodeLib.Common.Tools.dll b/binaries/accunit/x86/AccessCodeLib.Common.Tools.dll index 56fef5b..38c806c 100644 Binary files a/binaries/accunit/x86/AccessCodeLib.Common.Tools.dll and b/binaries/accunit/x86/AccessCodeLib.Common.Tools.dll differ diff --git a/binaries/accunit/x86/AccessCodeLib.Common.VBIDETools.dll b/binaries/accunit/x86/AccessCodeLib.Common.VBIDETools.dll index 1c37652..d074124 100644 Binary files a/binaries/accunit/x86/AccessCodeLib.Common.VBIDETools.dll and b/binaries/accunit/x86/AccessCodeLib.Common.VBIDETools.dll differ diff --git a/source/AccUnit/Configuration/Configurator.cs b/source/AccUnit/Configuration/Configurator.cs index 25068ae..855eec6 100644 --- a/source/AccUnit/Configuration/Configurator.cs +++ b/source/AccUnit/Configuration/Configurator.cs @@ -19,6 +19,8 @@ public interface IConfigurator void RemoveAccUnitLoaderFactoryModule(VBProject VBProject = null); void ExportTestClasses(string ExportPath = null, VBProject VBProject = null); void ImportTestClasses(string FileNameFilter = null, string ImportPath = null, VBProject VBProject = null); + + IUserSettings UserSettings { get; } } [ComVisible(true)] @@ -126,6 +128,14 @@ public void ImportTestClasses(string FileNameFilter = null, string importPath = } } + public IUserSettings UserSettings + { + get + { + return Configuration.UserSettings.Current; + } + } + /* public static void CheckAccUnitVBAReferences(VBProject vbProject) { diff --git a/source/AccUnit/Configuration/SettingForm.cs b/source/AccUnit/Configuration/SettingForm.cs new file mode 100644 index 0000000..e69de29 diff --git a/source/AccUnit/Configuration/TestClassManager.cs b/source/AccUnit/Configuration/TestClassManager.cs index 56590ed..f0ac05b 100644 --- a/source/AccUnit/Configuration/TestClassManager.cs +++ b/source/AccUnit/Configuration/TestClassManager.cs @@ -220,7 +220,9 @@ private string ApplicationName get { var fileInfo = new FileInfo(ActiveVBProject.FileName); - return fileInfo.Name; + var fileName = fileInfo.Name; + fileName = fileName.Substring(0, fileName.Length - fileInfo.Extension.Length); + return fileName; } } diff --git a/source/AccUnit/Configuration/UserSettings.cs b/source/AccUnit/Configuration/UserSettings.cs index 7175ed9..08c1201 100644 --- a/source/AccUnit/Configuration/UserSettings.cs +++ b/source/AccUnit/Configuration/UserSettings.cs @@ -5,10 +5,23 @@ using System.ComponentModel; using System.ComponentModel.Design; using System.Drawing.Design; +using System.Runtime.InteropServices; namespace AccessCodeLib.AccUnit.Configuration { - public class UserSettings + [ComVisible(true)] + [Guid("4E224321-17E1-43E7-8C37-97B7F09C4D81")] + public interface IUserSettings + { + string TestClassNameFormat { get; set; } + string ImportExportFolder { get; set; } + string TemplateFolder { get; set; } + string TestMethodTemplate { get; set; } + + void Save(); + } + + public class UserSettings : IUserSettings { #region Static members @@ -103,7 +116,7 @@ public void Save() // ReSharper restore MemberCanBePrivate.Global #region Tools - + [Category("Import/Export")] [DefaultValue(@"%APPFOLDER%\Tests\%APPNAME%")] [Description("Import and export folder for test classes\n%APPFOLDER% ... Path to current mdb/accdb\n%APPNAME% ... Filename of mdb/accdb")] diff --git a/source/AccUnit/Properties/Settings.Designer.cs b/source/AccUnit/Properties/Settings.Designer.cs index 7c13fc1..d9708e5 100644 --- a/source/AccUnit/Properties/Settings.Designer.cs +++ b/source/AccUnit/Properties/Settings.Designer.cs @@ -12,7 +12,7 @@ namespace AccessCodeLib.AccUnit.Properties { [global::System.Runtime.CompilerServices.CompilerGeneratedAttribute()] - [global::System.CodeDom.Compiler.GeneratedCodeAttribute("Microsoft.VisualStudio.Editors.SettingsDesigner.SettingsSingleFileGenerator", "17.6.0.0")] + [global::System.CodeDom.Compiler.GeneratedCodeAttribute("Microsoft.VisualStudio.Editors.SettingsDesigner.SettingsSingleFileGenerator", "17.7.0.0")] internal sealed partial class Settings : global::System.Configuration.ApplicationSettingsBase { private static Settings defaultInstance = ((Settings)(global::System.Configuration.ApplicationSettingsBase.Synchronized(new Settings())));