Option Compare Database
Option Explicit
Private Function GetFormName(frm As Form) As String
Dim strFormName As String
strFormName = frm.Name
On Error Resume Next 'Because form may not have a parent.
strFormName = frm.Parent.Name & "-" & strFormName
GetFormName = strFormName
End Function
Private Function GetPkFieldName(frm As Form) As String
Dim db As DAO.Database
Dim fld As DAO.Field
Dim idx As DAO.Index
Dim td As DAO.TableDef
Set db = CurrentDb
For Each fld In frm.RecordsetClone.Fields
Set td = db.TableDefs(fld.SourceTable)
For Each idx In td.Indexes
If idx.Primary = True Then
Debug.Assert idx.Fields.Count = 1 'Cannot handle composite keys.
GetPkFieldName = idx.Fields(0).Name
Exit Function
End If
Next idx
Next fld
Debug.Print
End Function
Private Function GetControlBoundToFieldName(frm As Form, ByVal strFieldName As String) As Control
Dim ctl As Control
On Error Resume Next 'Not every control has a ControlSource property.
For Each ctl In frm.Controls
If ctl.ControlSource = strFieldName Then
If Err.Number = 0 Then
Set GetControlBoundToFieldName = ctl
Exit Function
Else
Err.Clear
End If
End If
Next ctl
End Function
'Sub AuditChanges(MyForm As Form, IDField As Control)
'Sub AuditChanges(IDField As Control, Optional frm As Object = Nothing)
Sub AuditChanges(ByVal IDField As Control, Optional ByVal frm As Form = Nothing)
On Error GoTo AuditChanges_Err
Dim C As Control, xName As String
'Set MyForm = Me 'Screen.ActiveForm
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim ctl As Control
Dim datTimeCheck As Date
Dim UserName As String
'Dim whoseonnow As Table
Set cnn = CurrentProject.Connection
Set rst = New ADODB.Recordset
'Set idfield = Screen.ActiveForm.PrimaryKey
rst.Open "SELECT * FROM AuditTrail where 1 = 0", cnn, adOpenDynamic, adLockOptimistic
datTimeCheck = Now()
'For Each ctl In frm.Controls 'Screen.ActiveForm.Controls
If frm Is Nothing Then
Set frm = Screen.ActiveForm
End If
For Each ctl In frm.Controls
If ctl.ControlType = acSubform Then
'TvS: Don't call recursively: subform has its own call to AuditChanges.
'AuditChanges IDField, frm.Controls(ctl.ControlName).Form 'Object
Else
If ctl.Tag = "Audit" Then
If Nz(ctl.Value) <> Nz(ctl.OldValue) Then
With rst
.AddNew
![DateTime] = datTimeCheck
![UserName] = DLookup("[currentuser]", "whoseonnow")
![FormName] = GetFormName(frm) 'Screen.ActiveForm.Name
'![audittrailpk] = Screen.ActiveForm.Controls(PK).Value
'![ResidentID] = GetControlBoundToFieldName(frm, GetPkFieldName(frm)).Value
![pk] = GetControlBoundToFieldName(frm, GetPkFieldName(frm)).Value
![FieldName] = ctl.ControlSource
![OldValue] = ctl.OldValue
![NewValue] = ctl.Value
.Update
End With
End If
End If
End If
Next ctl
AuditChanges_Exit:
On Error Resume Next
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
Exit Sub
AuditChanges_Err:
MsgBox Err.Description, vbCritical, "ERROR!"
Resume AuditChanges_Exit
Resume
End Sub