Solved Audit trail error (1 Viewer)

[Kayleigh]

Hi,
I'm setting up an audit trail for all elements in my DB. It should record when updates are made and store in tblAudit.
This is the main code:

Option Compare Database
Option Explicit

Const cDQ As String = """"
Public Sub AuditTrail(frm As Form, recordid As Control)
  'Track changes to data.
  'recordid identifies the pk field's corresponding
  'control in frm, in order to id record.
  Dim ctl As Control
  Dim varBefore As Variant
  Dim varAfter As Variant
  Dim strControlName As String
  Dim strSQL As String
  Dim user As Integer
 
  user = Forms!frmLogin!cmbstaff.Value
 
  On Error GoTo ErrHandler
  'Get changed values.
  For Each ctl In frm.Controls
    With ctl
    'Avoid labels and other controls with Value property.
    If .ControlType = acTextBox Then
      If .Value <> .OldValue Then
        varBefore = .OldValue
        varAfter = .Value
        strControlName = .Name
        'Build INSERT INTO statement.
        strSQL = "INSERT INTO " _
           & "tblAuditTrail (fldEditDate, fldUser, fldRecordID, fldSourceTable, " _
           & " fldSourceField, fldBeforeValue, fldAfterValue) " _
           & "VALUES (Now()," _
           & cDQ & user & cDQ & ", " _
           & cDQ & recordid.Value & cDQ & ", " _
           & cDQ & frm.RecordSource & cDQ & ", " _
           & cDQ & .Name & cDQ & ", " _
           & cDQ & varBefore & cDQ & ", " _
           & cDQ & varAfter & cDQ & ")"
        'View evaluated statement in Immediate window.
        Debug.Print strSQL
        DoCmd.SetWarnings False
        DoCmd.RunSQL strSQL
        DoCmd.SetWarnings True
      End If
    End If
    End With
  Next
  Set ctl = Nothing
  Exit Sub

ErrHandler:
  MsgBox Err.Description & vbNewLine _
   & Err.Number, vbOKOnly, "Error"
End Sub

I have enclosed a very basic sample DB where I have applied this. The problem is:
a) It will not work for combo boxes or other controls which are not textboxes.
b) When executed in my main DB it will flag data mismatch error '13' - possibly due to a value in the control but have not managed to resolve.

Can anyone assist me here please?

 

[jdraw]

Post a representative database with test data and use/issue with checkbox.

 

[bastanu]

Please have a look at the updated file.
Cheers,
Vlad

 

[Kayleigh]

Thanks. I actually ascertained that it wasn't the audit trail not doing its job - proof being that checkboxes were working on other forms but the Before Update event was not firing so I have done a workaround to update the audit on the Before Update of the control and this works well.

 

[gcarpenter]

Please take a look at this change-tracking code, taken from a production system:
Change Tracking in Access
there are a few differences that should be incorporated.

wvMitchell, I cannot get the tag part down, where do I put the tag in the form and what should the tag be? Much appreciate the help.

 

[Kayleigh]

wvMitchell, I cannot get the tag part down, where do I put the tag in the form and what should the tag be? Much appreciate the help.

Hi,
In short the word 'audit' must be added to the tag property of every control you wish to audit. I have some useful code which iterates through every form to do so.

Option Compare Database
Option Explicit

Dim bIsLoaded As Boolean

'Iterate through forms
Public Sub tagsAllForms()

    On Error GoTo Err_tagsAllForms
    Dim oForm As Form
    Dim nItem As Long
    
    Dim db As dao.Database
    Dim cnt As dao.Container
    Dim doc As dao.Document
    
    Set db = CurrentDb
    Set cnt = db.Containers("Forms")
    
    For Each doc In cnt.Documents
  '  Debug.Print doc.Name
     If IsFormLoaded(doc.Name) Then bIsLoaded = True
        If Not bIsLoaded Then
           ' On Error Resume Next
            DoCmd.OpenForm doc.Name, acDesign, , , , acHidden
        End If
        Set oForm = Forms(doc.Name)
        changeTag oForm.Name
        If Not bIsLoaded Then
            On Error Resume Next
            DoCmd.Close acForm, oForm.Name
        End If
    Next doc
    
    Set db = Nothing
    
    

    MsgBox "Successfully updated audit trail in all forms.", vbInformation + vbOKOnly, gtstrAppTitle

Exit_tagsAllForms:
    Exit Sub

Err_tagsAllForms:
    MsgBox Err.Description, vbExclamation, "tagsAllForms Error " & Err.Number
    Resume Exit_tagsAllForms
End Sub

'Change tags to audit
Public Sub changeTag(sForm As String)

    
    On Error GoTo Err_changeTag
    Dim aO As AccessObject
    Dim fm As Access.Form
    Dim ct As Access.Control
    For Each aO In CurrentProject.AllForms
        If aO.Name = sForm Then
            Set fm = Forms(aO.Name)
            For Each ct In fm.Controls
                If isBound(ct) Then
                    ct.Tag = "audit"
                End If
            Next ct
            Set fm = Nothing
            If Not bIsLoaded Then
                On Error Resume Next
                DoCmd.Close acForm, aO.Name, acSaveYes
            End If
            Exit For
        End If
    Next

Exit_changeTag:
    Exit Sub

Err_changeTag:
    MsgBox Err.Description, vbExclamation, "changeTag Error " & Err.Number
    Resume Exit_changeTag
End Sub


'Check if control is bound
Public Function isBound(ctl As Control) As Boolean

    
    On Error GoTo Err_isBound
    Const cBoundControls As String = _
        "|Textbox|Combobox|Listbox|CheckBox|OptionButton|ToggleButton|"
    Dim ctlTypName As String, ctlSource As String
    ctlTypName = "|" & TypeName(ctl) & "|"
    isBound = False
    If InStr(1, cBoundControls, ctlTypName) <> 0 Then
        ctlSource = ctl.ControlSource
        If Len(ctlSource) > 0 Then
            If Left$(ctlSource, 1) <> "=" Then
                'the control is bound
                isBound = True
            End If
        End If
    End If

Exit_isBound:
    Exit Function

Err_isBound:
    MsgBox Err.Description, vbExclamation, "isBound Error " & Err.Number
    Resume Exit_isBound
End Function

Good luck!

 

[gcarpenter]

wvMitchell, I cannot get the tag part down, where do I put the tag in the form and what should the tag be? Much appreciate the help.

Please disregard, I figured it out. Thanks for the link, works perfect.