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#

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

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/functions/persist
'Environment  : VBA 2010 +
'Version      : 1.2.0
'Name         : list
'Author       : Stefan Erb (ERS)
'History      : 27.05.2014 - ERS - Creation
'               ...
'               27.08.2014 - ERS - Eingabe als Set-String hinzugefügt
'               09.09.2014 - ERS - Auswertung der Parameter neu über cDict
'-------------------------------------------------------------------------------
 
'-------------------------------------------------------------------------------
'   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 Const C_SETSTRING_PATTERN = "(?:(['""#])(?!\\)(.+?)\1(?!\\)|([0-9\.]+?))\s*(?:>=|[:=])\s*(?:\]([^\[]+)\[|(['""])(?!\\)(.+?)\5(?!\\)|(\w+))"
Private rxCachedSetString As Object
 
'/**
' * 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 = cDict(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, cast(fieldsDict(key), tbl.fields(fld.name).type)
                Else
                    primarKeyDict.add key, Empty
                End If
            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
 
'-------------------------------------------------------------------------------
'-- Private methodes
'-------------------------------------------------------------------------------
 
'/**
' * Castet ein Wert in das Format, dass die DB erwartet.
' * zB. rs.seek geht nicht mit String auf Long.
' * @param  Variant
' * @param  DataTypeEnum
' * @return Variant
' */
Private Function cast(ByRef iValue As Variant, ByVal iVarType As DAO.DataTypeEnum) As Variant
    Select Case iVarType
        Case dbText:        cast = CStr(iValue)
        Case dbLong:        cast = CLng(iValue)
        Case dbInteger:     cast = CInt(iValue)
        Case dbBoolean:     cast = CBool(iValue)
        Case dbMemo:        cast = CStr(iValue)
        Case dbByte:        cast = CByte(iValue)
        Case dbSingle:      cast = CSng(iValue)
        Case dbCurrency:    cast = CCur(iValue)
        Case dbTimeStamp:   cast = CDate(iValue)
'        Case dbBinary:
        Case dbLongBinary:  cast = CLngPtr(iValue)
        Case Else:          cast = iValue
    End Select
End Function
 
'-------------------------------------------------------------------------------
'-- Private libraries
'-------------------------------------------------------------------------------
 
'/**
' * Wandelt verschiedene Formate in ein Dictionary um
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cdict
' * Version      : 2.0.1
' * Modify: UCase(key)
' * @param  ParamArray
' * @return Dictionary
' */
Private Function cDict(ByRef iItems() As Variant) As dictionary
    Set cDict = New dictionary
    Dim items() As Variant: items = CVar(iItems)
    Dim i As Integer, key As Variant, value As Variant
    Dim isList As Boolean
 
    If UBound(items) = -1 Then Exit Function
 
    'Prüfen ob 2 Parametetrs übergeben wurden
    If UBound(items) = 1 Then
        'Beide Parametrer sind Arrays -> Combine: Erster Array Keys, 2ter Values
        If IsArray(items(0)) And IsArray(items(1)) Then
            key = items(0): value = items(1)
            Dim delta As Long: delta = LBound(key) - LBound(value)
            ReDim Preserve value(LBound(value) To UBound(key) + delta)
            For i = LBound(key) To UBound(key)
                If Not cDict.exists(UCase(key(i))) Then cDict.add UCase(key(i)), value(i + delta)
            Next i
            Exit Function
        End If
    End If
 
    'Alle Items durchackern
    For i = 0 To UBound(items)
        Dim item As Variant: ref item, items(i)
        'Dictionary
        If Not isList And TypeName(item) = "Dictionary" Then
            For Each key In items(i).keys
                If Not cDict.exists(UCase(key)) Then cDict.add UCase(key), item.item(key)
            Next key
        'einsamer Array
        ElseIf Not isList And IsArray(item) Then
            For key = LBound(item) To UBound(item)
                If Not cDict.exists(UCase(key)) Then cDict.add UCase(key), item(key)
            Next key
        'SetString
        ElseIf Not isList And rxSetString.Test(StrReverse(item)) Then
            Dim mc As Object: Set mc = rxSetString.execute(StrReverse(item))
            Dim k As Integer: For k = mc.count - 1 To 0 Step -1
                Dim m As Object: Set m = mc(k)
                key = StrReverse(firstValue(m.SubMatches(6), m.SubMatches(5), m.SubMatches(3)))
                value = StrReverse(firstValue(m.SubMatches(2), m.SubMatches(1)))
                Select Case m.SubMatches(0)
                    Case "#":   value = eval("#" & value & "#")
                    Case Empty: value = CDec(value)
                    Case Else:  value = cRegExp("\\(['""])", rxpGlobal).Replace(value, "$1")
                End Select
                If Not cDict.exists(UCase(key)) Then cDict.add UCase(key), value
            Next k
        'Alles andere geht in ein WertePaar.
        ElseIf i = 0 Or isList Then
            If i Mod 2 = 0 Then
                key = item
            Else
                If Not cDict.exists(UCase(key)) Then cDict.add UCase(key), item
            End If
            isList = True
        End If
    Next i
    'Falls es sich um eine nicht abgeschlossene Liste handelt
    If isList And i Mod 2 <> 0 Then
        If Not cDict.exists(UCase(key)) Then cDict.add UCase(key), Empty
    End If
End Function
 
'-------------------------------------------------------------------------------
'-- Private methodes / properties for cDict()
'-------------------------------------------------------------------------------
'/**
' * Gibt den ersten Wert zurück, der nicht Nothing, Empty oder Null ist
' * @param  ParamArray
' * @return Variant
' */
Private Function firstValue(ParamArray items() As Variant) As Variant
    For Each firstValue In items
        If IsObject(firstValue) Then
            If Not firstValue Is Nothing Then Exit For
        Else
            If Not IsNull(firstValue) And Not firstValue = Empty Then Exit For
        End If
    Next
End Function
 
'/**
' * Gibt eine Refernez auf den Wert zurück
' * @param  Variant     Variable, di abgefüllt werden soll
' * @param  Variant     Value
' */
Private Sub ref(ByRef oItem As Variant, Optional ByRef iItem As Variant)
    If IsMissing(iItem) Then
        oItem = Empty
    ElseIf IsObject(iItem) Then
        Set oItem = iItem
    Else
        oItem = iItem
    End If
End Sub
 
'/**
' * Handelt den RegExp-Cache um ein Set-String zu zerlegen
' * @return RegExp
' */
Private Property Get rxSetString() As Object
    If rxCachedSetString Is Nothing Then
        Set rxCachedSetString = CreateObject("VBScript.RegExp")
        rxCachedSetString.Global = True
        rxCachedSetString.pattern = C_SETSTRING_PATTERN
    End If
    Set rxSetString = rxCachedSetString
End Property