Yaslaw.Info

User Tools

Site Tools

You are here: Yaslaw.Info » VBA » [VBA] MS Access » [VBA] [Access] Functions » [VBA][Access] persist()
Trace:
vba:access:functions:persist

Differences

This shows you the differences between two versions of the page.

Link to this comparison view

Both sides previous revision Previous revision
Next revision 		Previous revision
vba:access:functions:persist [09.09.2014 09:14:34]
yaslaw [Code] 		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 128: Line 136:
 <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/​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 +
-</code>+
vba/access/functions/persist.1410246874.txt.gz · Last modified: 09.09.2014 09:14:34 by yaslaw

Page Tools

Except where otherwise noted, content on this wiki is licensed under the following license: GNU Free Documentation License 1.3
GNU Free Documentation License 1.3 Donate Powered by PHP Valid HTML5 Valid CSS Driven by DokuWiki