Require to setup two tables, LogUpdateDelete and LogUpdateDeleteTmp, if you split your database into backend, put LogUpdateDelete on backend and LogUpdateDeleteTmp on frontend.
Table Structure:
DateTime (Date/Time)
User (Text)
LocalIP (Text)
SystemInfo (Text)
Op (Text)
Table (Text)
OldData (Memo) Property AppendOnly=No
NewData (Memo) Property AppendOnly=No
This will also need basSystemInfo.bas which i posted earlier on GetIpAddress Topic.
Known Issue: when the form RecordSource is base on query, the primary key must be on the first field on the query design, otherwise it won't log the CascadeDelete.
'14:57 04/11/2010 Update: Add check for Relationship on linked backend db
'09:48 12/10/2010 trying to access form Recordset property during BeforeDelete Event,
' sometimes will cause form to lose its recordsource when delete is canceled
' eg. Msgbox frm.Recordset.AbsolutePosition on OnDelete() function
'15:55 04/10/2010 Purpose: Log record update and delete into a table, including cascade delete
'
'Copyright © 2010 RENO
Option Compare Text
'Option Explicit
#Const OPTION_EXPLICIT = False
Private Const logTable As String = "LogUpdateDelete"
Private Const tmpTable As String = "LogUpdateDeleteTmp"
Private sBookmark As String 'var to check if record(s) is deleted on ConfirmDelete
'---------------------------------------------------------------------------------
'insert this 4 functions into each form that need logging
'EVENT MACRO
'On Delete =OnDelete([Form])
'After Del Confirm =ConfirmDelete([Form])
'Before Update =BeforeUpdate([Form])
'After Update =ConfirmUpdate([Form])
'
'Alternative: use InsertIntoForms() to quickly add the code into All Forms
'---------------------------------------------------------------------------------
Public Function OnDelete(frm As Form)
' save current record before the record is actually deleted
' if more than one records is deleted, this event will be trigger for each of the record
On Error GoTo ErrHandler
'save the current bookmark to check record status on ConfirmDelete function
sBookmark = frm.Bookmark
LogTempTable frm, "Delete"
ExitHere:
Exit Function
ErrHandler:
HandleError "OnDelete()"
DoCmd.CancelEvent
Resume ExitHere
End Function
Public Function ConfirmDelete(frm As Form) As Boolean
' Check if the record has been deleted, and update Log Table
' Triggered only once even more than one records is deleted
' return true if user press 'Yes' on the confirm msgbox
On Error Resume Next
'if the record is deleted, this line of code will raise an error
frm.Bookmark = sBookmark
ConfirmDelete = (Err.Number = 3167) 'Or Err.Number = 3021 'record deleted
On Error GoTo ErrHandler
If ConfirmDelete = True Then
CurrentDb.Execute "INSERT INTO " & logTable & " SELECT * FROM " & tmpTable
End If
'clear temp table
CurrentDb.Execute "DELETE FROM " & tmpTable
ExitHere:
Exit Function
ErrHandler:
HandleError "ConfirmDelete()"
Resume ExitHere
End Function
Public Function BeforeUpdate(frm As Form)
#If OPTION_EXPLICIT = False Then
'set UpdatedOn and UpdatedBy Field, use ajbFieldLevel module if exist
'http://allenbrowne.com/ser-55.html
On Error Resume Next
ajbFieldLevel.StampRecord frm
#End If
On Error GoTo ErrHandler
If frm.NewRecord = False Then LogTempTable frm, "Update"
ExitHere:
Exit Function
ErrHandler:
HandleError "BeforeUpdate()"
DoCmd.CancelEvent
Resume ExitHere
End Function
Public Function ConfirmUpdate(frm As Form)
On Error GoTo ErrHandler
If frm.NewRecord Then Exit Function
'update tmp table with new values after update
frm.Recordset.Bookmark = frm.Bookmark
Dim f As DAO.Field: For Each f In frm.Recordset.Fields
ConfirmUpdate = ConfirmUpdate & f.name & "=" & IIf(f.IsComplex(), "", f.value) & vbCrLf
Next
'insert BeforeUpdate and AfterUpdate data into logTable
CurrentDb.Execute "UPDATE " & tmpTable & " SET NewData=""" & Replace(ConfirmUpdate, """", "'") & """"
CurrentDb.Execute "INSERT INTO " & logTable & " SELECT * FROM " & tmpTable
'clear temp table
CurrentDb.Execute "DELETE FROM " & tmpTable
ExitHere:
Exit Function
ErrHandler:
HandleError "ConfirmUpdate()"
Resume ExitHere
End Function
Public Function CloseRecordset(ByRef rs As DAO.Recordset)
' helper function to close Recordset
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
End Function
'-------------------------------------------------------------------------------
'internal method
'LogTempTable -> LogCascade -> GetCascadeRelation -> GetCascadeRelationInDB
'-------------------------------------------------------------------------------
Private Function LogTempTable(frm As Form, op As String)
' Save current record to temp table
' op - operation "Update" or "Delete"
On Error GoTo ErrHandler
Dim rsCurrent As DAO.Recordset
Dim rsTemp As DAO.Recordset
DoCmd.Hourglass True
'need this to avoid form losing recordsource
Set rsCurrent = frm.RecordsetClone
rsCurrent.Bookmark = frm.Bookmark
'save the current record to temp table
Dim f As DAO.Field: For Each f In rsCurrent.Fields
LogTempTable = LogTempTable & f.name & "=" & IIf(f.IsComplex(), "", f.value) & vbCrLf
Next
'log update/delete attempt to tmptable
Set rsTemp = CurrentDb.OpenRecordset(tmpTable, , dbAppendOnly)
rsTemp.AddNew
rsTemp!DateTime = Now()
rsTemp!op = op
rsTemp!user = UserName()
rsTemp!LocalIP = Left$(LocalIP(), 255)
rsTemp!SystemInfo = Left$(SystemInfo(), 255)
rsTemp!table = frm.RecordSource
rsTemp!OldData = Replace(LogTempTable, """", "'")
rsTemp.Update
LogCascade op, rsCurrent, rsTemp
ExitHere:
CloseRecordset rsTemp
CloseRecordset rsCurrent
DoCmd.Hourglass False
Exit Function
ErrHandler:
HandleError "LogTempTable()"
Resume ExitHere
End Function
Private Function LogCascade(op As String, rsCurrent As DAO.Recordset, rsTemp As DAO.Recordset)
' Recursively Log DeleteCascade for the Recordset specified in rsCurrent
' rsCurrent - current recordset position in which to search for cascade relation
' rsTemp - input recordset pointed to tmpTable
On Error GoTo ErrHandler
Dim rel As DAO.Relation
Dim rsCascade As DAO.Recordset
'check for cascade delete
If op = "Delete" Then Set rel = GetCascadeRelation(rsCurrent.Fields(0), dbRelationDeleteCascade)
If Not rel Is Nothing Then
'build sql string to retrieve effected records by cascade delete
Dim str: str = "SELECT * FROM [" & rel.ForeignTable & "] WHERE [" & rel.Fields(0).ForeignName & "]="
Select Case rsCurrent.Fields(0).Type
Case dbText: str = str & """" & rsCurrent.Fields(0).value & """"
Case dbDate: str = str & Format(rsCurrent.Fields(0).value, "\#mm\/dd\/yyyy\#")
Case Else: str = str & rsCurrent.Fields(0).value
End Select
'log the effected records to tmp table
Set rsCascade = CurrentDb.OpenRecordset(str)
While Not rsCascade.EOF
LogCascade = ""
Dim f As DAO.Field: For Each f In rsCascade.Fields
LogCascade = LogCascade & f.name & "=" & IIf(f.IsComplex(), "", f.value) & vbCrLf
Next
rsTemp.AddNew
rsTemp!DateTime = Now()
rsTemp!op = "Cascade" & op
rsTemp!user = UserName()
rsTemp!LocalIP = Left$(LocalIP(), 255)
rsTemp!SystemInfo = Left$(SystemInfo(), 255)
rsTemp!table = rsCascade.Fields(0).SourceTable
rsTemp!OldData = Replace(LogCascade, """", "'")
rsTemp.Update
'recursive call to log futher cascade
LogCascade op, rsCascade, rsTemp
rsCascade.MoveNext
Wend
End If
ExitHere:
CloseRecordset rsCascade
Exit Function
ErrHandler:
HandleError "LogCascade()"
Resume ExitHere
End Function
Private Function GetCascadeRelation(fld As DAO.Field, CascadeType As RelationAttributeEnum) As DAO.Relation
' check if a Field is in relation to another table by CascadeType
' return relation
On Error GoTo ErrHandler
Dim rs As DAO.Recordset
Dim db As DAO.Database
'check relation in current db
Set GetCascadeRelation = GetCascadeRelationInDB(CurrentDb, fld, CascadeType)
If Not GetCascadeRelation Is Nothing Then GoTo ExitHere
'14:57 04/11/2010 check relation in linked tables
Set rs = CurrentDb.OpenRecordset("SELECT Database, Connect From MSysObjects Where Flags=2097152 Group By Database, Connect")
While Not rs.EOF
Set db = OpenDatabase(rs.Fields(0), False, True, rs.Fields(1))
Set GetCascadeRelation = GetCascadeRelationInDB(db, fld, CascadeType)
db.Close
Set db = Nothing
rs.MoveNext
If Not GetCascadeRelation Is Nothing Then GoTo ExitHere
Wend
ExitHere:
CloseRecordset rs
Exit Function
ErrHandler:
HandleError "GetCascadeRelation()"
Resume ExitHere
End Function
Private Function GetCascadeRelationInDB(db As DAO.Database, fld As DAO.Field, CascadeType As RelationAttributeEnum) As DAO.Relation
' 14:57 04/11/2010 call by GetCascadeRelation to check if a Field is in relation to another table
Dim rel As DAO.Relation
For Each rel In db.Relations
If (rel.Attributes And CascadeType) = CascadeType Then
If rel.table = fld.SourceTable And rel.Fields(0).name = fld.SourceField Then
'found matching relation, clone it
Set GetCascadeRelationInDB = CurrentDb.CreateRelation(rel.name, rel.table, rel.ForeignTable, rel.Attributes)
Dim i: For i = 0 To rel.Fields.count - 1
GetCascadeRelationInDB.Fields.Append GetCascadeRelationInDB.CreateField(rel.Fields(i).name)
GetCascadeRelationInDB.Fields(i).ForeignName = rel.Fields(i).ForeignName
Next
Exit Function
End If
End If
Next
End Function
'----------------------------------
'function for debugging
'----------------------------------
Private Sub InsertIntoForms()
' script to insert above four functions into all the forms Event handler
Dim f As AccessObject
Dim frm As Form
Dim s As String
For Each f In CurrentProject.AllForms
If Not f.name Like "frm*" And Not f.name Like "view*" And f.name <> "_MAIN MENU" And Not f.name Like "*Lookup" Then
If f.IsLoaded Then DoCmd.Close acForm, f.name
DoCmd.OpenForm f.name, acDesign
Set frm = Forms(f.name)
Debug.Print f.name
' Debug.Print vbTab & "RecordSource=""" & frm.RecordSource & """"
s = vbTab & "OnDelete" & vbTab & vbTab & frm.OnDelete
frm.OnDelete = "=OnDelete([Form])"
Debug.Print s & " ---> " & frm.OnDelete & """ "
s = vbTab & "AfterDelConfirm" & vbTab & frm.AfterDelConfirm
frm.AfterDelConfirm = "=ConfirmDelete([Form])"
Debug.Print s & " ---> " & frm.AfterDelConfirm; ""
s = vbTab & "BeforeUpdate" & vbTab & frm.BeforeUpdate
frm.BeforeUpdate = "=BeforeUpdate([Form])"
Debug.Print s & " ---> " & frm.BeforeUpdate; ""
s = vbTab & "AfterUpdate" & vbTab & vbTab & frm.AfterUpdate
frm.AfterUpdate = "=ConfirmUpdate([Form])"
Debug.Print s & " ---> " & frm.AfterUpdate
DoCmd.Close acForm, f.name, acSaveYes
End If
Next
End Sub
Private Sub ShowCurrentDbRelations()
ShowRelations
End Sub
Private Sub ShowRelations(Optional db As Database)
Dim rel As Relation
If db Is Nothing Then Set db = CurrentDb
For Each rel In db.Relations
Debug.Print "Relation " & rel.name
Debug.Print vbTab & "Table = " & rel.table & vbTab & "ForeignTable = " & rel.ForeignTable
Debug.Print vbTab & "PK=" & rel.table & "." & rel.Fields(0).name & vbTab & "FK=" & rel.ForeignTable & "." & rel.Fields(0).ForeignName
Debug.Print vbTab & "Attributes=" & rel.Attributes
Debug.Print vbTab & "DeleteCascade=" & ((rel.Attributes And dbRelationDeleteCascade) = dbRelationDeleteCascade)
Debug.Print vbTab & "UpdateCascade=" & ((rel.Attributes And dbRelationUpdateCascade) = dbRelationUpdateCascade)
Next
End Sub Download Here: basLogUpdateDelete.bas
Download Sample Database (Access 2007): LogUpdateDelete.rar
No comments:
Post a Comment