Audit Trail for unbound forms/textboxes

Question

I have been searching for days for ways on how to implement an audit trail in my access 2010 database. There are plenty of solutions out there that work great when the form is bound, but I have several forms that are unbound and perform certain critical functions I wish to have an audit trail on (they are unbound due to having to edit different tables depending on user input, functions performed through VB and SQL scripting, so binding them to a table would not work). But there seems to be no easy solutions on this type of auditing without doing weeks and weeks worth of custom coding. Does anyone have any ideas on how to do this? Is there a way to audit all activity without having to bind a form? Can't I just have code that monitors a table's changes without having to go though code on the back side of the forms?

Answer 1

I have recently done this!

Each form has code to write changes to a table. The Audit Trail gets a bit tricky when you lose Screen.ActiveForm.Controls as the reference - which happens if you use a Navigation Form.

It is also using Sharepoint lists so I found that none of the published methods were available.

I (often) use a form in the middle as a display layer and I find it has to fire the Form_Load code in the next forms down the line as well. Once they are open they need to be self sustaining.

Module Variable;

Dim Deleted() As Variant



Private Sub Form_BeforeUpdate(Cancel As Integer)
'Audit Trail - New Record, Edit Record
    Dim rst As Recordset
    Dim ctl As Control
    Dim strSql As String
    Dim strTbl As String

    Dim strSub As String
    strSub = Me.Caption & " - BeforeUpdate"
    If TempVars.Item("AppErrOn") Then
        On Error Resume Next 'On Error GoTo Err_Handler
    Else
        On Error GoTo 0
    End If

    strTbl = "tbl" & TrimL(Me.Caption, 6)
    strSql = "SELECT * FROM tblzzAuditTrail WHERE DateTimeMS = #" & GetTimeUTC & "#;"
    Set rst = dbLocal.OpenRecordset(strSql)

    For Each ctl In Me.Detail.Controls
        If ctl.ControlType = acTextBox Or ctl.ControlType = acComboBox Then
            If ctl.Name <> "DateUpdated" Then
                If Nz(ctl.Value) <> Nz(ctl.OldValue) Then
                    If Me.NewRecord Then
                        With rst
                            .AddNew
                            !DateTimeMS = GetTimeUTC()
                            !UserID = TempVars.Item("CurrentUserID")
                            !ClientID = TempVars.Item("frmClientOpenID")
                            !RecordID = Me.Text26
                            !ActionID = 1
                            !TableName = strTbl
                            !FieldName = ctl.ControlSource
                            !NewValue = ctl.Value
                            .Update
                        End With
                    Else
                        With rst
                            .AddNew
                            !DateTimeMS = GetTimeUTC()
                            !UserID = TempVars.Item("CurrentUserID")
                            !ClientID = TempVars.Item("frmClientOpenID")
                            !RecordID = Me.Text26
                            !ActionID = 2
                            !TableName = strTbl
                            !FieldName = ctl.ControlSource
                            !NewValue = ctl.Value
                            !OldValue = ctl.OldValue
                            .Update
                        End With
                    End If
                End If
            End If
        End If
    Next ctl
    rst.Close
    Set rst = Nothing
Exit Sub

Err_Handler:
    Select Case Err.Number
        Case 3265
        Resume Next 'Item not found in recordset
        Case Else
        'Unexpected Error
        MsgBox "The following error has occurred" & vbCrLf & vbCrLf & "Error Number: " & _
        Err.Number & vbCrLf & "Error Source: " & strSub & vbCrLf & "Error Description: " & _
        Err.Description, vbExclamation, "An Error has Occured!"
    End Select
    rst.Close
    Set rst = Nothing
End Sub

Private Sub Form_Delete(Cancel As Integer)
    Dim ctl As Control
    Dim i As Integer
    Dim strTbl As String

    strTbl = "tbl" & TrimL(Me.Caption, 6)

    ReDim Deleted(3, 1)
    For Each ctl In Me.Detail.Controls
        If ctl.ControlType <> acLabel Then
 '       Debug.Print .Name
            If ctl.Name <> "State" And ctl.Name <> "Pcode" Then
                If Nz(ctl.Value) <> "" Then
                  Deleted(0, i) = ctl.ControlSource
                  Deleted(1, i) = ctl.Value
                  Deleted(2, i) = Me.Text26
'                  Debug.Print Deleted(0, i) & ", " & Deleted(1, i)
                  i = i + 1
                  ReDim Preserve Deleted(3, i)
                End If
            End If
        End If
    Next ctl
End Sub

Private Sub Form_AfterDelConfirm(Status As Integer)
    Dim rst As Recordset
    Dim ctl As Control
    Dim strSql As String
    Dim strTbl As String
    Dim i As Integer

    Dim strSub As String
    strSub = Me.Caption & " - AfterDelConfirm"
    If TempVars.Item("AppErrOn") Then
        On Error Resume Next 'On Error GoTo Err_Handler
    Else
        On Error GoTo 0
    End If

    strTbl = "tbl" & TrimL(Me.Caption, 6)
    strSql = "SELECT * FROM tblzzAuditTrail WHERE DateTimeMS = #" & GetTimeUTC() & "#;"
    Set rst = dbLocal.OpenRecordset(strSql)
'Audit Trail - Deleted Record
    If Status = acDeleteOK Then
        For i = 0 To UBound(Deleted, 2) - 1
            With rst
                .AddNew
                !DateTimeMS = GetTimeUTC()
                !UserID = TempVars.Item("CurrentUserID")
                !ClientID = TempVars.Item("frmClientOpenID")
                !RecordID = Deleted(2, i)
                !ActionID = 3
                !TableName = strTbl
                !FieldName = Deleted(0, i)
                !NewValue = Deleted(1, i)
                .Update
            End With
        Next i
    End If
    rst.Close
    Set rst = Nothing
Exit Sub

Err_Handler:
    Select Case Err.Number
        Case 3265
        Resume Next 'Item not found in recordset
        Case Else
        'Unexpected Error
        MsgBox "The following error has occurred" & vbCrLf & vbCrLf & "Error Number: " & _
        Err.Number & vbCrLf & "Error Source: " & strSub & vbCrLf & "Error Description: " & _
        Err.Description, vbExclamation, "An Error has Occured!"
    End Select
    rst.Close
    Set rst = Nothing
End Sub