Access 2010 Audit Trail on SubForms

问题:

I am having trouble getting the code I found for an audit trail to work with sub forms. The origninal code is from http://www.fontstuff.com/access/acctut21.htm. I would rather stick to this code than using Allen Browne's code http://allenbrowne.com/appaudit.html. It seems to be a problem with Screen.ActiveForm.Controls. I have read that this does not work with sub forms. Is there a way I can alter this to audit a sub form in my database?

When I record the data in the sub form, I get the following error: Microsoft can't find the field "CalSubID" referred to in your expression."

In a module I have this code (this is just part of it that I think is having issues):

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 = Forms!Login!cboUser.Column(1)
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

Then in my "before update" and "AfterDelConfirm" events for the subform I have (where "CalSubID" is the PK for the subform and this is what the main module code uses to track the changes):

-----------------------------------------------------------------------
Private Sub Form_BeforeUpdate(Cancel As Integer)
If Me.NewRecord Then
    Call AuditChanges("CalSubID", "NEW")
Else
    Call AuditChanges("CalSubID", "EDIT")
End If
End Sub
-----------------------------------------------------------------------
Private Sub Form_AfterDelConfirm(Status As Integer)
If Status = acDeleteOK Then Call AuditChanges("CalSubID", "DELETE")
End Sub
-----------------------------------------------------------------------

Modified 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

'added code
Dim SubFormName As String

Set cnn = CurrentProject.Connection
Set rst = New ADODB.Recordset
rst.Open "SELECT * FROM tblAuditTrail", cnn, adOpenDynamic, adLockOptimistic
datTimeCheck = Now()
strUserID = Forms!Login!cboUser.Column(1)

'msgbox to display name (just for now to test code)
MsgBox (" " & Screen.ActiveForm.Name & " ")

'IF THEN statement to check if user is using form with subform
If Screen.ActiveForm.Name = "Cal Form" Then
SubFormName = "Cal Form Sub"

    Select Case UserAction
    Case "EDIT"
        For Each ctl In Screen.ActiveForm
            If ctl.ControlType = acSubform Then
            SubFormName = ctl.Name
            If ctl.Tag = "Audit" Then
                If Nz(ctl.Value) <> Nz(ctl.OldValue) Then
                    With rst
                        .AddNew
                        ![DateTime] = datTimeCheck
                        ![UserName] = strUserID
                        ![FormName] = SubFormName
                        ![Action] = UserAction
                        ![RecordID] = Forms![Screen.ActiveForm.Name]![SubFormName].Form![IDField].Value
                        ![FieldName] = ctl.ControlSource
                        ![OldValue] = ctl.OldValue
                        ![NewValue] = ctl.Value
                        .Update
                    End With
                End If
            End If
'Getting error message at the --Next ctl-- line below, "next without for" message....
        Next ctl
    Case Else
        With rst
            .AddNew
            ![DateTime] = datTimeCheck
            ![UserName] = strUserID
            ![FormName] = SubFormName
            ![Action] = UserAction
            ![RecordID] = Forms![Screen.ActiveForm.Name]![SubFormName].Form![IDField].Value
            .Update
        End With
        Set ctl = Nothing
End Select

Else

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

回答1:

I'm presuming your error is with the line (it would help if you would verify):

![RecordID] = Screen.ActiveForm.Controls(IDField).Value

The issue as you've stated is that you can't access subform controls this way but must reference in this manner:

![RecordID] = Forms![main form name]![subform control name].Form![control name].Value

In your case, you need to first find the subform control name (presuming you only have 1 subform)

' Visit each control on the form
Dim ctl As Control
Dim SubFormName as string
SubFormName = ""
For Each ctl In Screen.ActiveForm
    If ctl.ControlType = acSubform Then
        SubFormName = ctl.Name
        exit for
    End If
Next ctl
Set ctl = Nothing

Now in your code when setting RecordID, you can do it like this:

' you should check that SubFormName is not empty before this next line...
![RecordID] = Forms![Screen.ActiveForm.Name]![SubformName].Form![IDField].Value

I have not tested this and I'm a bit rusty on Access, so take the concept and fix the syntax.

** UPDATE** - Here is the code I would try with the new information you have provided. I am presuming that the controls (e.g. the one with ctl.Tag = "Audit") are all on the subform

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

'added code
Dim SubFormName As String

Set cnn = CurrentProject.Connection
Set rst = New ADODB.Recordset
rst.Open "SELECT * FROM tblAuditTrail", cnn, adOpenDynamic, adLockOptimistic
datTimeCheck = Now()
strUserID = Forms!Login!cboUser.Column(1)

'msgbox to display name (just for now to test code)
MsgBox (" " & Screen.ActiveForm.Name & " ")

'IF THEN statement to check if user is using form with subform
If Screen.ActiveForm.Name = "Cal Form" Then
  SubFormName = "Cal Form Sub"

    Select Case UserAction
    Case "EDIT"
        For Each ctl In Forms![Cal Form]![Cal Form Sub].Form
            If ctl.Tag = "Audit" Then
                If Nz(ctl.Value) <> Nz(ctl.OldValue) Then
                    With rst
                        .AddNew
                        ![DateTime] = datTimeCheck
                        ![UserName] = strUserID
                        ![FormName] = SubFormName
                        ![Action] = UserAction
                        ![RecordID] = Forms![Cal Form]![Cal Form Sub].Form![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] = SubFormName
            ![Action] = UserAction
            ![RecordID] = Forms![Cal Form]![Cal Form Sub].Form![IDField].Value
            .Update
        End With
        Set ctl = Nothing
    End Select

Else

  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
End If

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

回答2:

I actually have a much simpler solution. You need to pass the (sub)form object along to the main basAudit sub.

Now, becuase the subform is the one initiating the command, it will be passed along to basAudit sub instead of the ActiveForm (wich is the main form, not the subform).

Modify the basAudit module as followed:

Sub AuditChanges(IDField As String, UserAction As String, UsedForm As Form)
    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 UsedForm.Controls
                If ctl.Tag = "Audit" Then
                    If Nz(ctl.Value) <> Nz(ctl.OldValue) Then
                        With rst
                            .AddNew
                            ![DateTime] = datTimeCheck
                            ![UserName] = strUserID
                            ![FormName] = UsedForm.Name
                            ![Action] = UserAction
                            ![RecordID] = UsedForm.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] = UsedForm.Name
                ![Action] = UserAction
                ![RecordID] = UsedForm.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

Change the AfterDelConfirm sub as followed:

Private Sub Form_AfterDelConfirm(Status As Integer)
    If Status = acDeleteOK Then Call AuditChanges("Site", "DELETE", Form)
End Sub

And last, change the BeforeUpdate sub as followed:

Private Sub Form_BeforeUpdate(Cancel As Integer)
    If Me.NewRecord Then
        Call AuditChanges("Site", "NEW", Form)
    Else
        Call AuditChanges("Site", "EDIT", Form)
    End If
End Sub

回答3:

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 GoTo Err_Handler
    Else
        On Error GoTo 0
    End If

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

    For Each ctl In Me.Detail.Controls
        If ctl.ControlType = acTextBox Or ctl.ControlType = acComboBox Then
            If Nz(ctl.Value) <> Nz(ctl.OldValue) Then
                If Me.NewRecord Then
                    With rst
                        .AddNew
                        !DateTime = Now()
                        !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
                        !DateTime = Now()
                        !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
    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)
    If Me.Preferred.Value = 1 Then
        MsgBox "Cannot Delete Preferred Address." & vbCrLf & "Set Another Address as Preferred First.", vbOKOnly, "XXX Financial."
        Cancel = True
    End If

    ReDim Deleted(2, 1)
    For Each ctl In Me.Detail.Controls
        If ctl.ControlType = acTextBox Or ctl.ControlType = acComboBox Then
 '       Debug.Print ctl.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
'                  Debug.Print Deleted(0, i) & ", " & Deleted(1, i)
                  i = i + 1
                  ReDim Preserve Deleted(2, 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 GoTo Err_Handler
    Else
        On Error GoTo 0
    End If

    strTbl = "tbl" & TrimL(Me.Caption, 6)
    strSql = "SELECT * FROM tblzzAuditTrail WHERE DateTime = #" & Now() & "#;"
    Set rst = dbLocal.OpenRecordset(strSql)
'Audit Trail - Deleted Record
    If Status = acDeleteOK Then
        For i = 0 To UBound(Deleted, 2) - 1
            With rst
                .AddNew
                !DateTime = Now()
                !UserID = TempVars.Item("CurrentUserID")
                !ClientID = TempVars.Item("frmClientOpenID")
                !RecordID = Me.Text26
                !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