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.4.1
'Name         : persist
'Author       : Stefan Erb (ERS)
'History      : 27.05.2014 - ERS - Creation
'               ...
'               09.02.2015 - ERS - Neuste Verionen der Libraries eingespielt, Code leicht berarbeitet
'               04.03.2015 - ERS - Fehler behoben
'               24.11.2015 - ERS - Fehler behoben
'               13.11.2017 - ERS - cV() durch cVal() ersetzt
'               03.09.2019 - ERS - cDict auf Version 3.1.4 umgestgellt
'-------------------------------------------------------------------------------

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

Private Const dbAutoIncrField = 16
'/**
' * 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
    'Die Auswertung der Parameters ist analog zu cDict. Darum verwende ich diese Funktion
    Dim pExpressions() As Variant:      pExpressions = CVar(iExpressions)
    Dim fieldsDict      As Object:      Set fieldsDict = uCaseDictKeys(cDictA(pExpressions))

    Dim db              As Object:      Set db = CurrentDb
    Dim tbl             As Object:      Set tbl = db.TableDefs(iTableName)
    'PrimaryKey Infos auslesen
    Dim pkInfo          As Object:      Set pkInfo = getPkInfo(tbl)
    'Kein PrimaryKey vorhanden
    If pkInfo!indexName = Empty Then Err.Raise ERR_PERSIST_NO_PRIMARY_KEY, "persit", "Table have no Primary Key"
    'Key mit Daten befüllen
    Dim keys() As Variant:  keys = pkInfo!fields.keys
    Dim key As Variant:     For Each key In keys
        If fieldsDict.exists(key) Then pkInfo!fields(key) = cast(fieldsDict(key), tbl.fields(key).Type)
    Next key

    Dim pkValues() As Variant: pkValues = pkInfo!fields.items     'Bei LateBinding kann nicht mehr direkt über den Index auf die Itesm des Dictionary zugegriffen werden
    
    Dim pkCount As Long: pkCount = pkInfo!fields.count
    'Recordset öffnen und Eintrag anhand Primary key suchen
    Dim rs As Object: Set rs = tbl.openRecordset
    If tbl.Connect = "" Then    'Eigene Tabelle
        rs.index = pkInfo!indexName
        Select Case pkCount
            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
        Dim find() As String: ReDim find(pkCount - 1)
        Dim i As Integer: For i = 0 To pkCount - 1
            find(i) = Application.BuildCriteria(keys(i), pkInfo("types")(keys(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
    keys = fieldsDict.keys
    For Each key In keys
        'nur übernehmen, wenn es nicht das autoInkrementFeld ist
        If Not UCase(key) = UCase(pkInfo!autoIncrFld) Then rs(key) = fieldsDict.item(key)
    Next key
    
    'Alles speichern, schliessen, abbauen
    If Not pkInfo!autoIncrFld = Empty Then: persist = rs(pkInfo!autoIncrFld): Else: persist = IIf(pkInfo!fields.count = 1, rs(keys(0)), True)
    rs.update: rs.Close
    Set rs = Nothing: Set tbl = Nothing: Set fieldsDict = Nothing:  Set pkInfo = Nothing: Set db = Nothing
End Function

'-------------------------------------------------------------------------------
'-- Private methodes
'-------------------------------------------------------------------------------

'/**
' * Liest den PrimaryKey einer Tabelle aus
' * @param  TableDef
' * @return Dictionary(autoIncrFld => String, fields => Dictionary(NAME => Empty), indexName => String)
' */
Private Function getPkInfo(ByRef iTbl As Object) As Object
    Static cachedPkDicts    As Object
    If cachedPkDicts Is Nothing Then Set cachedPkDicts = CreateObject("scripting.Dictionary")
    
    Dim tblName             As String:      tblName = UCase(iTbl.name)
    If Not cachedPkDicts.exists(tblName) Then
        'CacheNode initialisieren
        Dim info As Object: Set info = cDict(Array("autoIncrFld", "fields", "types", "indexName"), Array(Empty, cDict(), cDict(), Empty))
        'Tabelle analysieren
        Dim pk As Object: For Each pk In iTbl.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 (iTbl.fields(fld.name).Attributes And dbAutoIncrField) Then info!autoIncrFld = fld.name     'Prüfen auf autoIncrement
                    info!fields.add key, Empty
                    info("types").add key, iTbl.fields(fld.name).Type
                Next fld: Set fld = Nothing
                info!indexName = pk.name
                Exit For
            End If
        Next pk
        cachedPkDicts.add tblName, info
    End If
    Dim keys() As Variant: keys = cachedPkDicts(tblName)!fields.keys
    Dim i As Long: For i = 0 To UBound(keys)
        cachedPkDicts(tblName)!fields(keys(i)) = Empty
    Next i
    Set getPkInfo = cachedPkDicts(tblName)
End Function

'/**
' * Setz alle Keys eines Dictionaries in Grossbuchstaben.
' * @param  Dictionary
' * @return Dictionary
' */
Private Function uCaseDictKeys(ByRef iDict As Object) As Object
    Dim keys() As Variant:  keys = iDict.keys
    Set uCaseDictKeys = CreateObject("scripting.Dictionary")
    Dim key As Variant: For Each key In keys
        uCaseDictKeys.add UCase(key), iDict(key)
    Next key
End Function

'/**
' * Castet ein Wert in das Format, dass die DB erwartet.
' * zB. rs.seek geht nicht mit String auf Long.
' * @param  Variant
' * @param  Integer     dao.DataTypeEnum
' * @return Variant
' */
Private Function cast(ByRef iValue As Variant, ByVal ivarType As Integer) As Variant
    Select Case ivarType
        Case 10:    cast = CStr(iValue)     'dbText
        Case 4:     cast = CLng(iValue)     'dbLong
        Case 3:     cast = CInt(iValue)     'dbInteger
        Case 1:     cast = CBool(iValue)    'dbBoolean
        Case 12:    cast = CStr(iValue)     'dbMemo
        Case 2:     cast = CByte(iValue)    'dbByte
        Case 6:     cast = CSng(iValue)     'dbSingle
        Case 5:     cast = CCur(iValue)     'dbCurrency
        Case 23:    cast = CDate(iValue)    'dbTimeStamp
'        Case dbBinary:
        Case 11:    cast = CLngPtr(iValue)  'dbLongBinary
        Case Else:  cast = iValue
    End Select
End Function

'-------------------------------------------------------------------------------
'-- Private libraries
'-------------------------------------------------------------------------------

'-- cDict V3.1.4
'/**
' * Wandelt verschiedene Formate in ein Dictionary um
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cdic
' * @param  ParamArray
' * @return Dictionary
' */
Private Function cDict(ParamArray iItems() As Variant) As Object
    If UBound(iItems) = -1 Then
        Set cDict = CreateObject("scripting.Dictionary")
    Else
        Dim items() As Variant:     items = CVar(iItems)
        Set cDict = cDictA(items)
    End If
End Function

'/**
' * Dito zu cDict(). Die Übergabe ist aber nicht ein ParamArray sondern ein Arry.
' * Dieser Aufruf wird vor allem im Einsatz in anderen Funktionen verwendet
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cdic
' * @param  Array
' * @return Dictionary
' */
Private Function cDictA(ByRef iItems() As Variant) As Object
    'Cache RegExp um einSet-String zu zerlegen
    Static rxSetString As Object:               If rxSetString Is Nothing Then Set rxSetString = cRx("/(|lluN|eslaf|eurt|(['""#](?![\\,])).+?\1(?!\\)|[\d\.]*)\s*(?:>=|[:=])\s*((['""](?!\\)).+?\4(?!\\)|(\](?!\\)).+?\[(?!\\)|[\w\s-]+)/ig")
    Static rxCharsInStringToUnicode As Object:  If rxCharsInStringToUnicode Is Nothing Then Set rxCharsInStringToUnicode = cRx("/([\[\]\{\}'""=;,])/")
    Static rxStrings As Object:                 If rxStrings Is Nothing Then Set rxStrings = cRx("/(['""])([^\1]+?)\1/g")
    Set cDictA = CreateObject("scripting.Dictionary")
    Dim mc As Object
    Dim items() As Variant:                     items = CVar(iItems)
    Dim 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
            Dim keys() As Variant:      keys = items(0)
            Dim values() As Variant:    values = items(1)
            Dim delta As Long:          delta = LBound(keys) - LBound(values)
            ReDim Preserve values(LBound(values) To UBound(keys) + delta)
            Dim i As Integer: For i = LBound(keys) To UBound(keys)
                If Not cDictA.exists(keys(i)) Then cDictA.add keys(i), values(i + delta)
            Next i
            Exit Function
        End If
    End If
    
    'Alle Items durchackern
    Dim cnt As Integer:     cnt = 0
    Dim item As Variant:    For Each item In items
        'Dictionary
        If Not isList And TypeName(item) = "Dictionary" Then
            For Each key In item.keys
                If Not cDictA.exists(key) Then cDictA.add key, item.item(key)
            Next key
        'einsamer Array
        ElseIf Not isList And IsArray(item) Then
            For key = LBound(item) To UBound(item)
                If Not cDictA.exists(key) Then cDictA.add key, item(key)
            Next key
        'SetString
        ElseIf Not isList And Not IsArray(item) And Not IsObject(item) Then
            'Alle []{}'"=;, innerhalb eines Strings in Unicode parsen
            If rxStrings.test(item) Then
                Set mc = rxStrings.execute(item)
                For i = mc.count - 1 To 0 Step -1
                    Dim substr As String: substr = mc(i).subMatches(1)
                    Do While rxCharsInStringToUnicode.test(substr)
                        substr = rxCharsInStringToUnicode.replace(substr, CStr(char2unicode(rxCharsInStringToUnicode.execute(substr)(0))))
                    Loop
                    Dim dm As String: dm = mc(i).subMatches(0)
                    item = replaceIndex(item, dm & substr & dm, mc(i).firstIndex, mc(i).length)
                Next i
            End If
            If rxSetString.test(StrReverse(item)) Then
                Set mc = rxSetString.execute(StrReverse(item))
                Dim k As Variant: For k = mc.count - 1 To 0 Step -1
                    key = cVal(unicodeDecode(StrReverse(mc(k).subMatches(2))))
                    value = cVal(unicodeDecode(StrReverse(mc(k).subMatches(0))))
                    If Not cDictA.exists(key) Then cDictA.add key, value
                Next k
                
            Else
                GoTo DEFAULT        'Zuerst wollte ich diesen GoTo nicht haben. Aber StrReverse() wirft ein Fehler wenn ein Objekt übergeben wird. Darum konnte der Test nicht im ElseIf durchgeführt werden.
            End If
        'Alles andere geht in ein WertePaar.
        ElseIf cnt = 0 Or isList Then
DEFAULT:
            If cnt Mod 2 = 0 Then
                key = item
            ElseIf Not cDictA.exists(key) Then cDictA.add key, item
            End If
            isList = True
        End If
        cnt = cnt + 1
    Next
    'Falls es sich um eine nicht abgeschlossene Liste handelt
    If isList And cnt Mod 2 <> 0 Then If Not cDictA.exists(key) Then cDictA.add key, Empty
End Function

'-------------------------------------------------------------------------------
'--- LIBRARIES for cDict
'-------------------------------------------------------------------------------

'/**
' * Es wird versucht, den Paramter in seine eigentlichen Typ zu wandeln. Gar mit Textausgaben oder parsen von SQL interessant
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cval
' * @example    cVal("Null") -> Null, cVal("True") -> -1, cVal("time") -> 15:08:37
' * @param  Variant
' * @return Variant
' */
Private Function cVal(ByVal iValue As Variant) As Variant
On Error Resume Next
    Set cVal = iValue: cVal = iValue: cVal = eval(iValue): cVal = eval(iValue & "()"): cVal = IIf(IsDate(iValue), CDate(iValue), cVal):
End Function


'/**
' * Dies ist die Minimalversion von cRegExp
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp#abgespeckte_version
' * mögliche Delemiter: @&!/~#=\|
' * mögliche Modifiers: g (Global), i (IgnoreCode, m (Mulitline)
' *
' * @example    myRx = cRx("/([a]{2,})/i") 'Finde alle folgen von a. Flag:IgnoreCase
' * @version    2.1.0 (01.12.2014)
' * @param      String      Pattern mit Delimiter und Modifier analog zu PHP
' * @return     Object      RegExp-Object
' */
Private Function cRx(ByVal iPattern As String) As Object
    Static rxP As Object:       Set cRx = CreateObject("VBScript.RegExp")
    If rxP Is Nothing Then:     Set rxP = CreateObject("VBScript.RegExp"): rxP.pattern = "^([@&!/~#=\|])?(.*)\1(?:([Ii])|([Gg])|([Mm]))*$"
    Dim sm As Object:           Set sm = rxP.execute(iPattern)(0).subMatches
    cRx.pattern = sm(1):        cRx.IgnoreCase = Not isEmpty(sm(2)):       cRx.Global = Not isEmpty(sm(3)):     cRx.Multiline = Not isEmpty(sm(4))
End Function

'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' *
' * Wandelt ein Unicode in ein Charakter
' * @example: unicode2char("\u20AC") -> '\€'
' * @param  String      Unicode
' * @return String      Char
' */
Private Function unicode2Char(ByVal iUnicode As String) As String
    unicode2Char = ChrW(replace(iUnicode, "\u", "&h"))
End Function

'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' *
' * Wandelt ein Charakter in ein Unicode
' * @example: char2unicode("€") -> '\u20AC'
' * @param  String(1)   Charakter, der gewandelt werden soll
' * @return String      Unicode
' */
Private Function char2unicode(ByVal iChar As String) As String
    char2unicode = Hex(AscW(iChar)) 'Hex-Wert ermitteln
    char2unicode = "\u" & String(4 - Len(char2unicode), "0") & char2unicode
End Function

'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' *
' * Ersetzt ein pestimmte Position in einem String
' * @param  String      Heystack
' * @param  String      Ersetzungsstring
' * @param  Integer     Position im String
' * @param  Integer     Länge des zu ersetzenden Strings
' */
Private Function replaceIndex(ByVal iExpression As Variant, ByVal iReplace As Variant, ByVal iIndex As Variant, Optional ByVal iLength As Integer = 1) As String
    replaceIndex = Left(iExpression, iIndex) & iReplace & Mid(iExpression, iIndex + iLength + 1)
End Function

'/**
' * Wandelt alle Unicodes in einem String in das eigentliche Zeichen zurück
' * @param  String
' * @return String
' */
Private Function unicodeDecode(ByVal iString) As String
    unicodeDecode = iString
    Static rx As Object
    If rx Is Nothing Then Set rx = cRx("/\\u[0-9A-F]{4}/i")
    Do While rx.test(unicodeDecode)
        unicodeDecode = rx.replace(unicodeDecode, unicode2Char(rx.execute(unicodeDecode)(0)))
    Loop
End Function