How do I modify Auditing Code to deal with Sub-Forms and Data Relationships? (1 Viewer)

Cark · Sep 20, 2019

I have been using the great guide at https://www.fontstuff.com/access/acctut21.htm to create an Audit Log in TblAuditTrail in my example database. This allows me to track any fields that have been tagged with "Audit" in the Tag property.

The code below is the snippet which is added to the Form's Before Update event and this is working when added to FrmOverview's Before Update Event (this is the Master Form), however this does not seem to be working for the Sub-Forms (FrmSubChangerProgramme, FrmSubGeneralInformation and FrmSubReplacementProgramme) when I add it to their respective Before Update Events.

Code:

    If Me.NewRecord Then
        Call AuditChanges("PartID", "NEW")
    Else
        Call AuditChanges("PartID", "EDIT")
    End If

Cark · Sep 20, 2019

The following is the code being used for the module basAudit module. Is it an issue with the ID field?:

Code:

Sub AuditChanges(IDField As String, UserAction As String)
    On Error GoTo AuditChanges_Err
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim ctl As Control
    Dim datTimeCheck As Date
    Dim strUserID As String
    Set cnn = CurrentProject.Connection
    Set rst = New ADODB.Recordset
    rst.Open "SELECT * FROM tblAuditTrail", cnn, adOpenDynamic, adLockOptimistic
    datTimeCheck = Now()
    strUserID = Environ("USERNAME")
    Select Case UserAction
        Case "EDIT"
            For Each ctl In Screen.ActiveForm.Controls
                If ctl.Tag = "Audit" Then
                    If Nz(ctl.Value) <> Nz(ctl.OldValue) Then
                        With rst
                            .AddNew
                            ![DateTime] = datTimeCheck
                            ![UserName] = strUserID
                            ![FormName] = Screen.ActiveForm.Name
                            ![Action] = UserAction
                            ![RecordID] = Screen.ActiveForm.Controls(IDField).Value
                            ![FieldName] = ctl.ControlSource
                            ![OldValue] = ctl.OldValue
                            ![NewValue] = ctl.Value
                            .Update
                        End With
                    End If
                End If
            Next ctl
        Case Else
            With rst
                .AddNew
                ![DateTime] = datTimeCheck
                ![UserName] = strUserID
                ![FormName] = Screen.ActiveForm.Name
                ![Action] = UserAction
                ![RecordID] = Screen.ActiveForm.Controls(IDField).Value
                .Update
            End With
    End Select
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
End Sub

The_Doc_Man · Sep 20, 2019

however this does not seem to be working

To complete your problem description, what is the expected vs. actual behavior that leads you to say "does not seem to be working"??

arnelgp · Sep 20, 2019

add another parameter to the function, the form name:

Code:

    If Me.NewRecord Then
        Call AuditChanges(Me, "PartID", "NEW")
    Else
        Call AuditChanges(Me, "PartID", "EDIT")
    End If

the modified function:

Code:

Option Compare Database
Option Explicit

Sub AuditChanges(frm As Form, IDField As String, UserAction As String)
    On Error GoTo AuditChanges_Err
    'Dim cnn As ADODB.Connection
    'Dim rst As ADODB.Recordset
    Dim ctl As Control
    Dim datTimeCheck As Date
    Dim strUserID As String
    'Set cnn = CurrentProject.Connection
    'Set rst = New ADODB.Recordset
    'rst.Open "SELECT * FROM tblAuditTrail", cnn, adOpenDynamic, adLockOptimistic
    Set rst = CurrentDb.OpenRecordset("select * from tblAuditTrail where (1=0);", dbOpenDynaset)
    datTimeCheck = Now()
    strUserID = Environ("USERNAME")
    Select Case UserAction
        Case "EDIT"
            'For Each ctl In Screen.ActiveForm.Controls
            For Each ctl In frm.Controls
                If ctl.Tag = "Audit" Then
                    If Nz(ctl.value) <> Nz(ctl.OldValue) Then
                        With rst
                            .AddNew
                            ![DateTime] = datTimeCheck
                            ![UserName] = strUserID
                            '![FormName] = Screen.ActiveForm.Name
                            ![FormName] = frm.Name
                            ![Action] = UserAction
                            '![RecordID] = Screen.ActiveForm.Controls(IDField).value
                            ![RecordID] = frm.Controls(IDField).value
                            ![FieldName] = ctl.ControlSource
                            ![OldValue] = ctl.OldValue
                            ![newValue] = ctl.value
                            .Update
                        End With
                    End If
                End If
            Next ctl
        Case Else
            With rst
                .AddNew
                ![DateTime] = datTimeCheck
                ![UserName] = strUserID
                '![FormName] = Screen.ActiveForm.Name
                ![FormName] = frm.Name
                ![Action] = UserAction
                '![RecordID] = Screen.ActiveForm.Controls(IDField).value
                ![RecordID] = frm.Controls(IDField).value
                .Update
            End With
    End Select
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
End Sub

theDBguy · Sep 20, 2019

arnelgp said:
add another parameter to the function, the form name:

Hi Cark. I agree with Arnel's suggestion. It's the same approach I offerred earlier here. It should work for you too.

Cark · Sep 23, 2019

@arnelgp I copied across the modified function and the before update event code snippet and it was giving me errors that the Variable rst had not been defined as

Code:

Dim rst As ADODB.Recordset

has been quoted out. Is there a reason for this?

I tried playing around with removing the quotes from sections and also adding quotes in, however I have been unable to get this code to work.

arnelgp · Sep 23, 2019

copy my code, I am using DAO not ADODB.

Cark · Sep 23, 2019

Here is the error I am getting. Is it related to the

Code:

'Dim rst As ADODB.Recordset

line being quoted out?

Cark · Sep 23, 2019

I have gotten it working now. Thanks again arnelgp.

I have been reading up on ADODB and DAO and how ADODB is supposedly better for larger applications. Can you think of any example where I might get stuck using DAO with my database in the future?

arnelgp · Sep 23, 2019

you won't get stuck.
there were rumors before that ms will shelf dao in favor of a universal ado.
but just rumors.
dao now is much better now, on the coming of acedao.

Cark · Sep 23, 2019

Would I be able to use this same technique on List Boxes or would I have to make some amendments to the code?

arnelgp · Sep 23, 2019

how do you populate your listboxes?

Cark · Sep 23, 2019

So a bit of info on the List Boxes:

The List Box is unbound

The Row Source for the List Box comes from

Code:

SELECT TblFleet.FleetID, TblFleet.Fleet FROM TblFleet WHERE (((TblFleet.FleetID) Not In (SELECT TblFleetSelections.FleetID FROM TblFleetSelections INNER JOIN TblFleet ON TblFleetSelections.FleetID = TblFleet.FleetID WHERE TblFleetSelections.PartID=[Forms]![FrmOverview]![PartID]))) ORDER BY TblFleet.Fleet;

Selections from the List Box are made by double-clicking the item in the List Box which then runs some code of
Code:
```
If IsNull(Me.lstAvailable) Then Exit Sub sAddFleet ReqLists
```

Code:

Private Sub sAddFleet()

    Dim strSql As String

    strSql = "Insert into TblFleetSelections(PartID,FleetID) values(" & PartID & "," & Me.lstAvailable & ")"

    Debug.Print strSql

    CurrentDb.Execute strSql, dbFailOnError

End Sub

Private Sub ReqLists()

    Me.lstAvailable.Requery
    
    Me.lstSelected.Requery

    Me.lstAvailable.Value = Null
    
    Me.lstSelected.Value = Null

End Sub

Essentially I want to capture the item being removed from the box when I double-click and have it stored in TblAuditTrail.

arnelgp · Sep 23, 2019

you need to add the Tag ("Audit").
you need to manually call the AuditChange sub:

Code:

Private Sub sAddFleet()

    Dim strSql As String

    strSql = "Insert into TblFleetSelections(PartID,FleetID) values(" & PartID & "," & Me.lstAvailable & ")"

    Debug.Print strSql

    CurrentDb.Execute strSql, dbFailOnError

   [COLOR="Blue"] Call AuditChanges(Me, "PartID", "EDIT")[/COLOR]
End Sub

Cark · Sep 23, 2019

I thought that might be the code I would need, however it doesn't seem to be working.

Cark · Sep 23, 2019

I have attached the example to assist with picking through the code.

How to use / test the Database/Forms:

Double-Click FrmOverview to open up the Main Form
Click the Paper and Pencil Icon to Edit the Applicable Fleets
Double-Click on an Item in the Fleet List to move it from the Left Side Fleet List to the Applicable Fleets
Double-Click on an Item on the Right Side to move an item back from Applicable Fleets to Fleet List.
Click the Big Green Tick to close the Fleet Selector.

arnelgp · Sep 23, 2019

ok, change the Tag of the listbox to "ListAudit".
change this portion of code to:

Code:

..
..
                If ctl.Tag = "Audit" [COLOR="blue"]Or ctl.Tag = "ListAudit"[/COLOR] Then
                    If (Nz(ctl.value) <> Nz(ctl.OldValue)) [COLOR="Blue"]Or ctl.Tag = "ListAudit" [/COLOR]Then
..
..

Cark · Sep 23, 2019

Making the

Code:

                If ctl.Tag = "Audit" Or ctl.Tag = "ListAudit" Then
                    If (Nz(ctl.value) <> Nz(ctl.OldValue)) Or ctl.Tag = "ListAudit" Then

amendment has worked so far as I now have records being logged in the TblAuditTrail, however I am now getting 2 rows per selection made in FrmSelectFleet.

There are two things going on here that I would like to see if we can correct:

The Old Value and New Value fields are not populating correctly. The OldValue is always the same as the New Value, whereas these are supposed to be different. A second record is also put in with blank Old and New Values (see picture).
The FieldName is always blank because the ![FieldName] = ctl.ControlSource. This is because the List Box does not actually have a Control Source. I can get around this with an If statement so this is not an issue.

arnelgp · Sep 23, 2019

actually, we are Adding the record. so you might change "Edit" to "Add".
there will be no Oldvalue or New Value. since we are deleting it from the list.

Cark · Sep 24, 2019

For some reason it is also saving a record with everything populated except the OldValue and NewValue which is pretty much a duplicate of the line that was selected

How do I modify Auditing Code to deal with Sub-Forms and Data Relationships? (1 Viewer)

Registered User.

Attachments

Registered User.

Immoderate Moderator

..forever waiting... waiting for jellybean!

I’m here to help

Registered User.

..forever waiting... waiting for jellybean!

Registered User.

Attachments

Registered User.

..forever waiting... waiting for jellybean!

Registered User.

..forever waiting... waiting for jellybean!

Registered User.

..forever waiting... waiting for jellybean!

Registered User.

Registered User.

Attachments

..forever waiting... waiting for jellybean!

Registered User.

Attachments

..forever waiting... waiting for jellybean!

Registered User.

Attachments

Similar threads

Users who are viewing this thread