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
Last revision Both sides next revision
vba:access:functions:persist [01.09.2014 09:52:24]
yaslaw [Code] 		vba:access:functions:persist [24.11.2015 12:27:26]
yaslaw
Line 1: Line 1:
 +<​const>​
 +    version=1.3.7
 +    vdate=24.11.2015
 +    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.txt · Last modified: 04.09.2019 11:57:48 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