基于SubForms的Access 2010审计跟踪

Question

我在获得审计跟踪使用子表单的代码时遇到了困难。原名代码来自http://www.fontstuff.com/access/acctut21.htm。我宁愿坚持使用这段代码，也不愿使用Allen的代码http://allenbrowne.com/appaudit.html。这似乎是Screen.ActiveForm.Controls的一个问题。我已经读到，这不适用于子表单。有什么方法可以修改它来审计数据库中的子表单吗？

当我在子表单中记录数据时，我会得到以下错误:微软找不到表达式中提到的字段"CalSubID“。

在一个模块中，我有以下代码(这只是我认为有问题的部分代码)：

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

然后，在我的“更新前”和"AfterDelConfirm“事件中，我拥有的子表单(其中"CalSubID”是子表单的PK，这是主要模块代码用于跟踪更改的内容)：

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

修改后的守则：

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

Answer 1

我假定您的错误与这一行有关(如果您要验证的话，这会有所帮助)：

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

正如您已经说过的，您不能以这种方式访问子窗体控件，但必须以这种方式进行引用：

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

在您的情况下，您需要首先找到子窗体控件名称(假设您只有一个子窗体)。

' 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

现在，在您的代码中设置RecordID时，您可以这样做：

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

我还没有对此进行测试，而且我在访问方面有点生疏，所以请考虑这个概念并修复语法。

** UPDATE** -这是我将尝试使用您提供的新信息的代码。我假定控件(例如带有ctl.Tag =“审核”的控件)都在子表单上

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

Answer 2

其实我有一个简单得多的解决方案。您需要将( sub )form对象传递给主basAudit子对象。

现在，因为子表单是发起命令的，所以it将被传递给basAudit Sub而不是ActiveForm (wich是主要形式，而不是子表单)。

按以下方式修改basAudit模块：

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

按照以下方式更改AfterDelConfirm子程序：

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

最后，将BeforeUpdate子更改如下：

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

Answer 3

我最近这么做了！

每个表单都有对表进行更改的代码。当您失去作为引用的Screen.ActiveForm.Controls时，审计跟踪会变得有点棘手--如果使用导航表单，就会发生这种情况。

它还在使用Sharepoint列表，因此我发现所有已发布的方法都不可用。

我(经常)使用中间的一个表单作为显示层，我发现它也必须在下一个表单中触发Form_Load代码。一旦他们打开，他们需要自我维持。

模块变量；

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