This is an old revision of the document!
Eine Funktion für ein einfacher INSERT INTO…ON DUPLICATE UPDATE
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.
id = persist(table, feld-1, value-1 [,feld-2, value-2...[,feld-n, value-n]]) id = persist(table, array(feld1 [,feld2...[,feld#]]), array(value1 [,value2]...[,value#]])) id = persist(table, dictionary) id = persist(table, string)
Public Function persist( _ ByVal iTableName As String, _ ParamArray iExpressions() As Variant _ ) As Variant
Für die Auswertungen verwende ich [VBA][Access] printRs() und [VBA] print_r().
Ich habe mal die folgenden 2 Tabellen (Felder des PrimaryKey sind mit * markiert)
TBL_EXCHANGE | ||
---|---|---|
CCY_FROM* | CCY_TO* | EXCHANGE_VALUE |
CHF | EUR | 1.2 |
CHF | USD | 1.01 |
TBL_USER | ||
---|---|---|
ID* | VORNAME | NACHNAME |
1 | Hans | Müller |
2 | Susanne | Keller |
3 | Kurt | Sutter |
4 | Miriam | Hablützel |
Public Sub testPersist() printRs CurrentDb.OpenRecordset("tbl_exchange") 'Kurs CHF-GPB mit 2.1 eintragen print_r persist("tbl_exchange", "ccy_from", "CHF", "ccy_to", "GBP", "exchange_value", 2.1) printRs CurrentDb.OpenRecordset("tbl_exchange") 'Kurs nochmals eintragen, dieses mal mit 2.2. Der Aufruf bleibt gleich. 'Das wird den alten Kurs überschreiben, da die Kombination CHF-GBP bereits vorhanden ist print_r persist("tbl_exchange", "ccy_from", "CHF", "ccy_to", "GBP", "exchange_value", 2.2) printRs CurrentDb.OpenRecordset("tbl_exchange") End Sub
Und das ist die Ausgabe. Man sieht, wie zuerst die Kombination CHF-GBP hinzugefügt wird und mit dem zweiten Aufruf von persist() verändert wird.
| CCY_FROM | CCY_TO | EXCHANGE_VALUE | |----------|--------|----------------| | CHF | EUR | 1.2 | | CHF | USD | 1.01 | <Long> 64 | CCY_FROM | CCY_TO | EXCHANGE_VALUE | |----------|--------|----------------| | CHF | EUR | 1.2 | | CHF | USD | 1.01 | | CHF | GBP | 2.1 | <Long> 48 | CCY_FROM | CCY_TO | EXCHANGE_VALUE | |----------|--------|----------------| | CHF | EUR | 1.2 | | CHF | USD | 1.01 | | CHF | GBP | 2.2 |
Public Sub testPersistUser() printRs CurrentDb.OpenRecordset("tbl_users") 'Frau Keller heiratet und wechselt den Namen auf Meier print_r persist("tbl_users", "id", "2", "nachname", "Meier") printRs CurrentDb.OpenRecordset("tbl_users") 'Eine Frau Ruth Peter wird eingetragen. ID wird automatisch erstellt print_r persist("tbl_users", "vorname", "Ruth", "nachname", "Peter") printRs CurrentDb.OpenRecordset("tbl_users") End Sub
| ID | VORNAME | NACHNAME | |----|---------|-----------| | 1 | Hans | Müller | | 2 | Susanne | Keller | | 3 | Kurt | Sutter | | 4 | Miriam | Hablützel | <Long> 48 | ID | VORNAME | NACHNAME | |----|---------|-----------| | 1 | Hans | Müller | | 2 | Susanne | Meier | | 3 | Kurt | Sutter | | 4 | Miriam | Hablützel | <Long> 64 | ID | VORNAME | NACHNAME | |----|---------|-----------| | 1 | Hans | Müller | | 2 | Susanne | Meier | | 3 | Kurt | Sutter | | 4 | Miriam | Hablützel | | 5 | Ruth | Peter |
Die Folgenden Beispiele bewirken alle dasselbe Resultat. Ein Datensatz mit einem Namen und einer externen System-ID wird abgefüllt und kriegt eine neue ID. Danach wird dieser Record um das Geburtstdatum ergänzt. Am Ende sieht dann die Tabelle so aus
| ID | USER NAME | BIRTHDAY | SYSTEM-ID | |----|------------|------------|-----------| | 1 | Stefan Erb | 01.06.1972 | 123 |
'Neuen Datensatz erstellen Dim newId As Long newId = persist("T_USERS_INFO", "user name", "Stefan Erb", "system-id", 123) 'Datensatz anpassen persist "t_users_info", "id", newId, "birthday", #6-1-1972#
'Neuen Datensatz erstellen Dim newId As Long newId = >persist("T_USERS_INFO", array("user name", "system-id"), array("Stefan Erb", 123)) 'Datensatz anpassen persist "t_users_info", array("id", "birthday"), array(1, #6-1-1972#)
'Neuen Datensatz erstellen Dim dict As New dictionary dict.add "user name", "Stefan Erb" dict.add "system-id", 123 Dim newId As Long newId = persist("T_USERS_INFO", dict) 'Datensatz anpassen dict.RemoveAll dict.add "id", newId dict.add "birthday", #6/1/1972# persist "t_users_info", dict
'Neuen Datensatz erstellen 'Anstelle von "" im String kann auch ' verwendet werden Dim newId As Long newId = persist "T_USERS_INFO", "[user name]=""Stefan Erb"", [system-id] = 123" 'Datensatz anpassen persist "t_users_info", "id=1, birthday = #6-1-1972#"
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/functions/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 '------------------------------------------------------------------------------- '------------------------------------------------------------------------------- ' 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. ' ' INSERT INTO...ON DUPLICATE UPDATE ' Geprüft wird nur auf den Primary Key einer Tabelle ' ' 1) Immer abwechselnd Feldname, Value ' ------------------------------------ ' id = persist(table, feld1, value1 [,feld2, value2...[,feld#, value#]]) ' @example: persist "my_table", "id", 34, "f_string", "abcd3", "f_date", now, "f_double", 234.5 ' ' 2) Zwei gleich grosse Array. Der erste beinhaltet die Feldnamen, der Zweite die Werte ' ------------------------------------------------------------------------------------- ' id = persist(table, array(feld1 [,feld2...[,feld#]]), array(value1 [,value2]...[,value#]])) ' @example: persist "my_table", array("id", "f_string"), array(34, "abcd3") ' ' 3) Ein oder mehrere Dictionary. dict.key => Feldnamen, dict.value => Wert ' ------------------------------------------------------------------------- ' id = persist(table, dictionary) ' @example: persist "my_table", my_dictionary ' ' 4) Ein Set-String (ohne das Wort Set) wie man ihn für ein Update-SQL kennt ' -------------------------------------------------------------------------- ' id = persist(table, string) ' @example: persist "my_table", "id = 34, [f_string] = 'abcd3', f_date = #1-12-2013#, f_double = 234.5" '------------------------------------------------------------------------------- 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 'Cachen von RegExp-Objekten Private rxString As Object 'Zerlegen eines Set-Strings '/** ' * INSERT INTO...ON DUPLICATE UPDATE ' * Geprüft wird nur auf den Primary Key einer Tabelle ' * ' * @param String Name der Tabelle ' * @param ParamArray Hier sind verschiedene Kombnationen möglich: Siehe Module-Beschreibung ' * @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 = "\[?([\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 Dim outKey As String: outKey = UCase(key) If Not ioDict.exists(outKey) Then ioDict.add outKey, 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