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.

Download udf_persist.bas

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

• iTableName Name der Tabelle
• iExpressions() Immer abwechselnd Feldname, Value

• return PrimaryKey

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)

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#

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
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#"

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