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 [01.09.2014 09:52:24]
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 21: Line 29:
   ***iExpressions()** Immer abwechselnd Feldname, Value   ***iExpressions()** Immer abwechselnd Feldname, Value
  
-  ***return** PrimaryKey+  ***return** ​%%PrimaryKey%%
  
 ===== Beispiele ===== ===== Beispiele =====
Line 126: Line 134:
  
 === 2 Arrays (Feld-Array & Value-Array) === === 2 Arrays (Feld-Array & Value-Array) ===
-<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.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 ienes Set-Strings +
-Private rxDate As Object ​   'Datum parsen +
-'/** +
-' * 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</​code>+
vba/access/functions/persist.1409557944.txt.gz · Last modified: 01.09.2014 09:52:24 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