This shows you the differences between two versions of the page.
Both sides previous revision Previous revision Next revision | Previous revision | ||
vba:access:functions:persist [27.08.2014 15:39:46] yaslaw [Beispiele zu den verschiedenen Anwendungsformaen] |
vba:access:functions:persist [04.09.2019 11:57:48] (current) yaslaw |
||
---|---|---|---|
Line 1: | Line 1: | ||
+ | <const> | ||
+ | version=1.4.1 | ||
+ | vdate=03.09.2019 | ||
+ | fname=udf_persist.bas | ||
+ | ns=%NAMESPACE% | ||
+ | fpath=/vba/access/functions | ||
+ | </const> | ||
====== [VBA][Access] persist() ====== | ====== [VBA][Access] persist() ====== | ||
- | Eine Funktion für ein einfacher INSERT INTO...ON DUPLICATE UPDATE | + | //Eine Funktion für ein einfacher INSERT INTO...ON DUPLICATE UPDATE// |
+ | ==Version %%version%% - %%vdate%%== | ||
Die Funktion eignet sich gut, um schnell eine kleine Änderung (Add /Update) auf eine Tabelle anhand des %%PrimaryKey%% auszuführen. | Die Funktion eignet sich gut, um schnell eine kleine Änderung (Add /Update) auf eine Tabelle anhand des %%PrimaryKey%% auszuführen. | ||
Die Funktion führt ein Insert aus, sofern der Primary-Key keine übereinstimmung gefunden hat. Ansonsten wird ein Update ausgeführt. | Die Funktion führt ein Insert aus, sofern der Primary-Key keine übereinstimmung gefunden hat. Ansonsten wird ein Update ausgeführt. | ||
- | {{:vba:access:udf_persist.bas|Download udf_persist.bas}} | + | {{%%fname%%|Download %%fname%% (V-%%version%%)}} |
===== Definition ===== | ===== Definition ===== | ||
<code>id = persist(table, feld-1, value-1 [,feld-2, value-2...[,feld-n, value-n]]) | <code>id = persist(table, feld-1, value-1 [,feld-2, value-2...[,feld-n, value-n]]) | ||
Line 21: | Line 29: | ||
***iExpressions()** Immer abwechselnd Feldname, Value | ***iExpressions()** Immer abwechselnd Feldname, Value | ||
- | ***return** PrimaryKey | + | ***return** %%PrimaryKey%% |
===== Beispiele ===== | ===== Beispiele ===== | ||
Line 126: | Line 134: | ||
=== 2 Arrays (Feld-Array & Value-Array) === | === 2 Arrays (Feld-Array & Value-Array) === | ||
- | <code vb'Neuen Datensatz erstellen | + | <code vb>'Neuen Datensatz erstellen |
Dim newId As Long | Dim newId As Long | ||
- | newId = >persist("T_USERS_INFO", array("user name", "system-id"), array("Stefan Erb", 123)) | + | newId = persist("T_USERS_INFO", array("user name", "system-id"), array("Stefan Erb", 123)) |
- | 'Datensatz anpassen | + | 'Datensatz anpassen, das Geburtsdatum ergänzen |
- | persist "t_users_info", array("id", "birthday"), array(1, #6-1-1972#) | + | persist "t_users_info", array("id", "birthday"), array(newId, #6-1-1972#) |
</code> | </code> | ||
Line 152: | Line 160: | ||
'Anstelle von "" im String kann auch ' verwendet werden | 'Anstelle von "" im String kann auch ' verwendet werden | ||
Dim newId As Long | Dim newId As Long | ||
- | newId = persist "T_USERS_INFO", "[user name]=""Stefan Erb"", [system-id] = 123" | + | newId = (persist "T_USERS_INFO", "[user name]=""Stefan Erb"", [system-id] = 123") |
'Datensatz anpassen | 'Datensatz anpassen | ||
- | persist "t_users_info", "id=1, birthday = #6-1-1972#" | + | persist "t_users_info", "id=" & newId & ", birthday = #6-1-1972#" |
</code> | </code> | ||
Line 162: | Line 170: | ||
===== Code ===== | ===== Code ===== | ||
- | + | <source '%%fpath%%/%%fname%%' vb> | |
- | <code vb udf_persist.bas>Attribute VB_Name = "udf_persist" | + | |
- | '------------------------------------------------------------------------------- | + | |
- | 'File : udf_persist.bas | + | |
- | ' Copyright mpl by ERB software | + | |
- | ' All rights reserved | + | |
- | ' http://wiki.yaslaw.info/dokuwiki/doku.php/vba/access/persist | + | |
- | 'Environment : VBA 2010 + | + | |
- | 'Version : 1.1.0 | + | |
- | 'Name : list | + | |
- | 'Author : Stefan Erb (ERS) | + | |
- | 'History : 27.05.2014 - ERS - Creation | + | |
- | ' ... | + | |
- | ' 27.08.2014 - ERS - Eingabe als Set-String hinzugefügt | + | |
- | '------------------------------------------------------------------------------- | + | |
- | Option Explicit | + | |
- | + | ||
- | Public Const ERR_PERSIST_INVALID_ARGUMENT_COUNT = vbObjectError + 501 'Der ParamArray hat eine ungerade Anzahl Argumente | + | |
- | Public Const ERR_PERSIST_NO_PRIMARY_KEY = vbObjectError + 502 'Die Tabelle hat kein PrimaryKey | + | |
- | Public Const ERR_PERSIST_TO_MATCH_FIELDS_IN_PK = vbObjectError + 503 'Der Seek() muss ausgebaut werden, damit die bestehende Anzahl Felder des PK abgedeckt sind | + | |
- | + | ||
- | Private rxString As Object | + | |
- | Private rxDate As Object | + | |
- | '/** | + | |
- | ' * INSERT INTO...ON DUPLICATE UPDATE | + | |
- | ' * Geprüft wird nur auf den Primary Key einer Tabelle | + | |
- | ' * | + | |
- | ' * id = persist(table, feld1, value1 [,feld2, value2...[,feld#, value#]]) | + | |
- | ' * id = persist(table, array(feld1 [,feld2...[,feld#]]), array(value1 [,value2]...[,value#]])) | + | |
- | ' * id = persist(table, dictionary) | + | |
- | ' * id = persist(table, string) | + | |
- | ' * | + | |
- | ' * @example: persist "my_table", "id", 34, "f_string", "abcd3", "f_date", now, "f_double", 234.5 | + | |
- | ' * @example: persist "my_table", array("id", "f_string"), array(34, "abcd3") | + | |
- | ' * @example: persist "my_table", my_dictionary | + | |
- | ' * @example: persist "my_table", "id = 34, [f_string] = 'abcd3', f_date = #1-12-2013#, f_double = 234.5" | + | |
- | ' * | + | |
- | ' * @param String Name der Tabelle | + | |
- | ' * @param ParamArray Hier sind verschiedene Kombnationen möglich: | + | |
- | ' * 1) Immer abwechselnd Feldname, Value | + | |
- | ' * 2) Zwei gleich grosse Array. Der erste beinhaltet die Feldnamen, der Zweite die Werte | + | |
- | ' * 3) Ein oder mehrere Dictionary. dict.key => Feldnamen, dict.value => Wert | + | |
- | ' * @return Variant Primary | + | |
- | ' */ | + | |
- | Public Function persist( _ | + | |
- | ByVal iTableName As String, _ | + | |
- | ParamArray iExpressions() As Variant _ | + | |
- | ) As Variant | + | |
- | Dim expressions() As Variant: expressions = CVar(iExpressions) | + | |
- | Dim fieldsDict As Object: Set fieldsDict = createDictFromExpressions(expressions) | + | |
- | Dim primarKeyDict As Object: Set primarKeyDict = CreateObject("scripting.Dictionary") | + | |
- | Dim db As Database: Set db = CurrentDb | + | |
- | Dim tbl As TableDef: Set tbl = db.TableDefs(iTableName) | + | |
- | Dim autoIncrFld As String: autoIncrFld = Empty | + | |
- | + | ||
- | 'Tabelle analysieren | + | |
- | Dim pk As index: For Each pk In tbl.Indexes | + | |
- | If pk.Primary Then 'Primary Key durchgehen | + | |
- | Dim fld As Variant: For Each fld In pk.fields | + | |
- | Dim key As String: key = UCase(fld.name) | + | |
- | If (tbl.fields(fld.name).Attributes And dbAutoIncrField) Then autoIncrFld = key 'Prüfen auf autoIncrement | + | |
- | If fieldsDict.exists(key) Then: primarKeyDict.add key, fieldsDict(key): Else: primarKeyDict.add key, Empty | + | |
- | Next fld: Set fld = Nothing | + | |
- | Exit For | + | |
- | End If | + | |
- | Next pk | + | |
- | + | ||
- | 'Kein PrimaryKey vorhanden | + | |
- | If Not pk.Primary Then Err.Raise ERR_PERSIST_NO_PRIMARY_KEY, "persit", "Table have no Primary Key" | + | |
- | + | ||
- | Dim pkValues() As Variant: pkValues = primarKeyDict.items 'Bei LateBinding kann nicht mehr direkt über den Index auf die Itesm des Dictionary zugegriffen werden | + | |
- | Dim pkKeys() As Variant: pkKeys = primarKeyDict.keys | + | |
- | 'Recordset öffnen und Eintrag anhand Primary key suchen | + | |
- | Dim rs As Dao.Recordset: Set rs = tbl.OpenRecordset | + | |
- | If tbl.Connect = "" Then 'Eigene Tabelle | + | |
- | rs.index = pk.name | + | |
- | Select Case primarKeyDict.count | + | |
- | Case 1: rs.Seek "=", pkValues(0) | + | |
- | Case 2: rs.Seek "=", pkValues(0), pkValues(1) | + | |
- | Case 3: rs.Seek "=", pkValues(0), pkValues(1), pkValues(2) | + | |
- | Case 4: rs.Seek "=", pkValues(0), pkValues(1), pkValues(2), pkValues(3) | + | |
- | Case Else: Err.Raise ERR_PERSIST_TO_MATCH_FIELDS_IN_PK, "persits", "PrimaryKey have to many fields" | + | |
- | '//TODO erweitern für grössere Indexe | + | |
- | End Select | + | |
- | Else 'Verlinkte Tabelle | + | |
- | 'Achtung Risiko: Date ggf falsches Format... | + | |
- | Dim find() As String: ReDim find(primarKeyDict.count - 1) | + | |
- | Dim i As Integer: For i = 0 To primarKeyDict.count - 1 | + | |
- | find(i) = pkKeys(i) & " = '" & pkValues(i) & "'" | + | |
- | Next i | + | |
- | rs.FindFirst Join(find, " AND ") | + | |
- | End If | + | |
- | 'AddNew oder Edit, je nach noMatch | + | |
- | If rs.NoMatch Then: rs.addNew: Else: rs.Edit | + | |
- | 'Felder übertragen mit Ausnahme eines Autoinkrement Feldes | + | |
- | Dim keys() As Variant: keys = fieldsDict.keys | + | |
- | Dim idx As Integer: For idx = 0 To fieldsDict.count - 1 | + | |
- | 'nur übernehmen, wenn es nicht das autoInkrementFeld ist | + | |
- | If Not keys(idx) = autoIncrFld Then rs(keys(idx)) = fieldsDict.item(keys(idx)) | + | |
- | Next idx | + | |
- | 'Alles speichern, schliessen, abbauen | + | |
- | If Not autoIncrFld = Empty Then: persist = rs(autoIncrFld): Else: persist = IIf(primarKeyDict.count = 1, rs(pk.fields(0).name), False) | + | |
- | rs.update: rs.Close | + | |
- | Set rs = Nothing: Set tbl = Nothing: Set fieldsDict = Nothing: Set primarKeyDict = Nothing: Set db = Nothing | + | |
- | + | ||
- | End Function | + | |
- | + | ||
- | '/** | + | |
- | ' * Erstellt ein Dictionary aufgrund eines ParamArrays | + | |
- | ' * @param Array<Variant> | + | |
- | ' * @retrun Dictionary | + | |
- | ' */ | + | |
- | Private Function createDictFromExpressions(ByRef iItems() As Variant) As dictionary | + | |
- | Set createDictFromExpressions = CreateObject("scripting.Dictionary") | + | |
- | 'Dictionary | + | |
- | If UBound(iItems) = 0 And TypeName(iItems(0)) = "Dictionary" Then | + | |
- | If fillByDictionary(createDictFromExpressions, iItems) Then Exit Function | + | |
- | End If | + | |
- | 'Set-String | + | |
- | If UBound(iItems) = 0 Then | + | |
- | If fillByString(createDictFromExpressions, iItems(0)) Then Exit Function | + | |
- | End If | + | |
- | ' | + | |
- | If UBound(iItems) = 1 Then | + | |
- | If IsArray(iItems(0)) And IsArray(iItems(1)) Then | + | |
- | If UBound(iItems(0)) = UBound(iItems(1)) Then | + | |
- | If fillByCombine(createDictFromExpressions, iItems) Then Exit Function | + | |
- | End If | + | |
- | End If | + | |
- | End If | + | |
- | If IsArray(iItems(0)) Then | + | |
- | If fillByArrayPairs(createDictFromExpressions, iItems) Then Exit Function | + | |
- | End If | + | |
- | fillByListInclKeys createDictFromExpressions, iItems | + | |
- | End Function | + | |
- | + | ||
- | '/** | + | |
- | ' * Die Angaben kommen alle als Set-String daher | + | |
- | ' * @param Dictionary | + | |
- | ' * @param Array<Array<Variant>> | + | |
- | ' */ | + | |
- | Private Function fillByString(ByRef ioDict As Object, ByVal iString As String) As Boolean | + | |
- | On Error GoTo Exit_Handler | + | |
- | If rxString Is Nothing Then | + | |
- | Set rxString = CreateObject("VBScript.RegExp") | + | |
- | rxString.Global = True | + | |
- | rxString.Pattern = "\[?([a\w ]+)\]?\s*=\s*(([""'#])[^\3]+?\3|now|(?![""'#])[\d\.]+)" | + | |
- | End If | + | |
- | fillByString = rxString.Test(iString) | + | |
- | Dim match As Variant: For Each match In rxString.execute(iString) | + | |
- | ioDict.add UCase(Trim(match.SubMatches(0))), eval(match.SubMatches(1)) | + | |
- | Next match | + | |
- | Exit_Handler: | + | |
- | End Function | + | |
- | + | ||
- | '/** | + | |
- | ' * Erster Array beinhaltet die Keys, der 2te die Values | + | |
- | ' * @param Dictionary | + | |
- | ' * @param Array<Array<Variant>> | + | |
- | ' */ | + | |
- | Private Function fillByCombine(ByRef ioDict As Object, ByRef iItems() As Variant) As Boolean | + | |
- | On Error GoTo Exit_Handler | + | |
- | Dim keys() As Variant: keys = iItems(LBound(iItems)) | + | |
- | Dim values() As Variant: values = iItems(LBound(iItems) + 1) | + | |
- | Dim delta As Integer: delta = LBound(keys) - LBound(values) 'Indexunterschied ermitteln | + | |
- | Dim idx As Integer: For idx = LBound(keys) To UBound(keys) | + | |
- | ioDict.add UCase(keys(idx)), values(idx + delta) | + | |
- | Next idx | + | |
- | fillByCombine = True | + | |
- | Exit_Handler: | + | |
- | End Function | + | |
- | + | ||
- | '/** | + | |
- | ' * Array-Paare abfüllen | + | |
- | ' * @param Dictionary | + | |
- | ' * @param Array<Array<Variant>> | + | |
- | ' */ | + | |
- | Private Function fillByArrayPairs(ByRef ioDict As Object, ByRef iItems() As Variant) As Boolean | + | |
- | On Error GoTo Exit_Handler | + | |
- | Dim idx As Integer: For idx = LBound(iItems) To UBound(iItems) | + | |
- | ioDict.add UCase(iItems(idx)(0)), iItems(idx)(1) | + | |
- | Next idx | + | |
- | fillByArrayPairs = True | + | |
- | Exit_Handler: | + | |
- | End Function | + | |
- | + | ||
- | '/** | + | |
- | ' * Alle elemente sind Dictionaries. Es wird ein Merge durchgeführt | + | |
- | ' * Bei mehreren Dictionarys und überschneidenden Keys ist das erste Dictionaryder Master | + | |
- | ' * @param Dictionary | + | |
- | ' * @param Array<Dictionary> | + | |
- | Private Function fillByDictionary(ByRef ioDict As Object, ByRef iItems() As Variant) As Boolean | + | |
- | On Error GoTo Exit_Handler | + | |
- | Dim idx As Integer: For idx = LBound(iItems) To UBound(iItems) | + | |
- | Dim key As Variant: For Each key In iItems(idx).keys | + | |
- | key = UCase(key) | + | |
- | If Not ioDict.exists(key) Then ioDict.add key, iItems(idx).item(key) | + | |
- | Next key | + | |
- | Next idx | + | |
- | fillByDictionary = True | + | |
- | Exit_Handler: | + | |
- | End Function | + | |
- | + | ||
- | '/** | + | |
- | ' * Eine Liste abfüllen. | + | |
- | ' * @param Dictionary | + | |
- | ' * @param Array<Variant> | + | |
- | ' */ | + | |
- | Private Function fillByListInclKeys(ByRef ioDict As Object, ByRef iItems() As Variant) As Boolean | + | |
- | On Error GoTo Exit_Handler | + | |
- | Dim idx As Integer: For idx = LBound(iItems) To UBound(iItems) Step 2 | + | |
- | On Error Resume Next | + | |
- | ioDict.add UCase(iItems(idx)), iItems(idx + 1) | + | |
- | If Err.Number = 5 Then | + | |
- | On Error GoTo 0: Err.Raise 13 '13 Type mismatch | + | |
- | ElseIf Err.Number > 0 Then | + | |
- | Err.Raise Err.Number | + | |
- | End If | + | |
- | On Error GoTo 0 | + | |
- | Next idx | + | |
- | fillByListInclKeys = True | + | |
- | Exit_Handler: | + | |
- | End Function | + | |
- | </code> | + |