Option Compare Database
Option Explicit
Dim dbs As DAO.Database
Dim sAuditTable As String
Dim sSQL As String
Dim sTable As String 'Table where the record is being edited
Dim CTL As Control 'The control in the form being edited
Dim sFrom As String 'Original Data in the control
Dim sTo As String 'What the original data was changed to
Dim sPCName As String 'Name of the PC that is being used
Dim sPCUser As String 'Name of the User on the Networked PC
Dim sDBUser As String 'Name of the Database User
Dim sDateTime As String 'Date and Time of the change
'===========================================================================================
'
' This Audit Trail will track changes to existing records.
' In the "Before Update" event of the FORM enter the following:
'
' Call AuditTrail(Me.Form, [RecordID])
'
' Make sure to create a table called "tbl_AuditLog" and have the following fields:
' (A table will be created automatically if it does not exist)
'
' 1. RecordID (This is a unique number)
' 2. txt_Table (This is the table where the record was changed)
' 3. lng_TblRecord (This is the RecordID number from the record being changed)
' 4. txt_Form (This is the form being used to edit the record)
' 5. txt_Control (This is the data entry control (field) that was edited
' 6. mem_From (This is the original data in the control (field)
' 7. mem_To (This is what the original data was changed to)
' 8. txt_PCName (This is the name of the PC used to edit the record)
' 9. txt_PCUser (This is the name of the user logged onto the PC)
' 10. txt_DBUser (This is the name of the person looged on to the databse if used)
' 11. dat_DateTime (This is the date and time the record was edited.)
'
'
' The inspiration behind this code is from:
' 1. http://support.microsoft.com/default.aspx?scid=kb;en-us;197592
' 2. http://www.access-programmers.co.uk/forums/showthread.php?t=44231
'
'
'============================================================================================
Public Function AuditTrail(frm As Form, lngRecord As Long)
On Error GoTo Error_Handler
'----------------------------------------------------------------------
' Skips this procedure if a new record is being entered in the form
'----------------------------------------------------------------------
If frm.NewRecord = True Then
Exit Function
End If
'----------------------------------------------------------------------
' Checks to see if the tbl_AuditLog Exists
' Creates the table if it does not exist
'----------------------------------------------------------------------
Set dbs = CurrentDb
dbs.TableDefs.Refresh
sAuditTable = "tbl_AuditLog"
On Error Resume Next
If IsNull(dbs.TableDefs(sAuditTable)) Then
'Table does not exist
On Error GoTo Error_Handler
sSQL = "CREATE TABLE tbl_AuditLog([RecordID] COUNTER PRIMARY KEY, [txt_Table] TEXT(50), [lng_TblRecord] LONG, " & _
"[txt_Form] TEXT(50), [txt_Control] TEXT(50), [mem_From] MEMO, [mem_To] MEMO, [txt_PCName] TEXT(50), " & _
"[txt_PCUser] Text(50), [txt_DBUser] Text(50), [dat_DateTime] DATETIME);"
DoCmd.SetWarnings False
DoCmd.RunSQL sSQL
DoCmd.SetWarnings True
Else
'Table Exists. Do Nothing
On Error GoTo Error_Handler
End If
Set dbs = Nothing
'----------------------------------------------------------------------
' Runs through each control on the form and checks for edits/changes
'----------------------------------------------------------------------
For Each CTL In frm
Select Case CTL.ControlType 'Only checks data entry type controls.
Case acTextBox, acComboBox, acListBox, acOptionGroup
sFrom = Nz(CTL.OldValue, "Null")
sTo = Nz(CTL.Value, "Null")
If sFrom <> sTo Then
'-----------------------------------
' Gets the required Info
'-----------------------------------
sTable = frm.RecordSource
sPCName = Environ("COMPUTERNAME")
sPCUser = Environ("Username")
sDBUser = "Me" 'Get Username from the database login
sDateTime = Now()
sSQL = "INSERT INTO tbl_AuditLog ([txt_Table], [lng_TblRecord], [txt_Form], [txt_Control], " & _
"[mem_From], [mem_To], [txt_PCName], [txt_PCUser], [txt_DBUser], [dat_DateTime]) " & _
"VALUES ('" & sTable & "', '" & lngRecord & "', '" & frm.Name & "', " & _
"'" & CTL.Name & "', '" & sFrom & "', '" & sTo & "', '" & sPCName & "', " & _
"'" & sPCUser & "', '" & sDBUser & "', '" & sDateTime & "')"
DoCmd.SetWarnings False
DoCmd.RunSQL sSQL
DoCmd.SetWarnings True
End If
End Select
Next CTL
Error_Handler_Exit:
Exit Function
Error_Handler:
MsgBox ("Error No: " & Err.Number & vbCrLf & vbCrLf & "Error Description: " & Err.Description)
Err.Clear
Resume Error_Handler_Exit
End Function
