Cascading Action Scripts

Sub CascadingActionEntry()
    CascadingAction "Stamm-Produkte", "Art-Nr", "1014"
End Sub
 
 
Sub CascadingAction(tabellenName As String, field As String, value As String)
 
' für alle referenzierenden datensätze (objekte) rekursiv CascadingBackup
' durchführen
Dim rel As Relation
Dim rs As Recordset
Dim sqlQuery As String
 
'+------Parent------------+                   +----Child-------------------------+
'| Table , Fields(0).Name | ----Relation------|ForeignTable,Fields(0).ForeignName|
'+------------------------+                   +----------------------------------+
 
'durch alle Relationen loopen (etwas umständlich)
For Each rel In CurrentDb.Relations
    'falls Relation mit dieser Tabelle
    If (rel.table = tabellenName) Then
        ' Alle kind objekte des gegenwärtigen Datensatzes (Objekt) über diese Relation (Kante) suchen
        'sqlQuery = "SELECT * FROM " & rel.ForeignTable & " WHERE " & rel.Fields(0).ForeignName & " = '" & value & "'"
        sqlQuery = getSelectString(rel.ForeignTable, rel.Fields(0).ForeignName, value)
        Set rs = CurrentDb.OpenRecordset(sqlQuery)
        Do While (Not rs.EOF)
            ' Für alle referenzierenden Objekte Aktion durchführen
            CascadingAction rel.ForeignTable, rel.Fields(0).ForeignName, rs(rel.Fields(0).Name)
            rs.MoveNext
        Loop
   End If
Next
'jetzt die eigentliche Aktion durchführen
'DELETE FROM tabellenName WHERE field = value
'MsgBox (tabellenName & " : " & value)
doBackup tabellenName, field, value
End Sub
 
 
Private Function getSelectString(table As String, field As String, value As String)
Dim sqlQuery As String
'falls der FK vom DatenType Text ist
If (CurrentDb.TableDefs(table).Fields(field).Type = dbText) Then
 sqlQuery = "SELECT * FROM [" & table & "] WHERE [" & field & "] = '" & value & "'"
 
Else
 sqlQuery = "SELECT * FROM [" & table & "] WHERE [" & field & "] = " & value
End If
 
 getSelectString = sqlQuery
End Function
 
 
 
Sub doBackup(tabellenName As String, field As String, value As String)
 
'falls Backup Tabelle nicht existiert
If (Not tableExists(tabellenName & "_archiv")) Then
    'kopie erstellen
    DoCmd.CopyObject , tabellenName & "_archiv", acTable, tabellenName
    CurrentDb.Execute ("DELETE FROM [" & tabellenName & "_archiv]")
End If
 
Dim sqlInsert As String
Dim sqlDelete As String
Dim sqlFields1 As String
Dim sqlFields2 As String
 
sqlFields1 = ""
sqlFields2 = ""
Dim i As Integer
Debug.Print (CurrentDb.TableDefs(tabellenName).Fields(1).Name)
 
For i = 0 To CurrentDb.TableDefs(tabellenName).Fields.Count - 2
'For Each f In CurrentDb.TableDefs(tabellenName).Fields
    sqlFields1 = sqlFields1 & " [" & CurrentDb.TableDefs(tabellenName).Fields(i).Name & "], "
    sqlFields2 = sqlFields2 & "[" & tabellenName & "].[" & CurrentDb.TableDefs(tabellenName).Fields(i).Name & "], "
Next i
sqlFields1 = sqlFields1 & "[" & CurrentDb.TableDefs(tabellenName).Fields(CurrentDb.TableDefs(tabellenName).Fields.Count - 1).Name & "]"
sqlFields2 = sqlFields2 & "[" & tabellenName & "].[" & CurrentDb.TableDefs(tabellenName).Fields(CurrentDb.TableDefs(tabellenName).Fields.Count - 1).Name & "]"
 
'falls das Feld vom DatenType Text ist
If (CurrentDb.TableDefs(tabellenName).Fields(field).Type = dbText) Then
sqlInsert = "INSERT  INTO [" & tabellenName & "_archiv] (" & sqlFields1 & ") SELECT " & sqlFields2 & " FROM [" & tabellenName & "] WHERE [" & tabellenName & "].[" & field & "]='" & value & "'"
sqlDelete = "DELETE FROM [" & tabellenName & "] WHERE [" & tabellenName & "].[" & field & "] ='" & value & "'"
 
Else
sqlInsert = "INSERT  INTO [" & tabellenName & "_archiv] (" & sqlFields1 & ") SELECT " & sqlFields2 & " FROM [" & tabellenName & "] WHERE [" & tabellenName & "].[" & field & "]=" & value
sqlDelete = "DELETE FROM [" & tabellenName & "] WHERE [" & tabellenName & "].[" & field & "] =" & value
 
End If
 
Debug.Print sqlDelete
 
 
CurrentDb.Execute (sqlInsert)
CurrentDb.Execute (sqlDelete)
'falls der FK vom DatenType Text ist
 
 
End Sub
 
 
Private Function tableExists(e As String) As Boolean
Dim i
Dim contains As Boolean
contains = False
For Each i In CurrentDb.TableDefs
    If i.Name = e Then
        contains = True
    End If
Next
tableExists = contains
End Function