1

我在获取用于审计跟踪的代码以使用子表单时遇到问题。原始代码来自http://www.fontstuff.com/access/acctut21.htm。我宁愿坚持这段代码，也不愿使用 Allen Browne 的代码http://allenbrowne.com/appaudit.html。这似乎是一个问题Screen.ActiveForm.Controls。我读过这不适用于子表单。有没有办法可以改变它来审核我的数据库中的子表单？

当我在子表单中记录数据时，出现以下错误：Microsoft 找不到您的表达式中引用的字段“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
4

3 回答 3

1

我假设您的错误与该行有关（如果您要验证会有所帮助）：

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

您所说的问题是您不能以这种方式访问​​子表单控件，但必须以这种方式引用：

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

在您的情况下，您需要首先找到子表单控件名称（假设您只有 1 个子表单）

' 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

我没有对此进行测试，而且我对 Access 有点生疏，所以请采用这个概念并修复语法。

** 更新** - 这是我将尝试使用您提供的新信息的代码。我假设控件（例如带有 ctl.Tag = "Audit" 的控件）都在子表单上

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
于 2014-08-13T06:14:19.867 回答
1

我实际上有一个更简单的解决方案。您需要将（子）表单对象传递给主basAudit子。

现在，因为子窗体是启动命令的那个，它将被传递给basAudit sub 而不是ActiveForm（这是主窗体，而不是子窗体）。

修改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
于 2017-10-25T22:01:23.853 回答
0

我最近做了这个！

每个表单都有代码来将更改写入表。当您丢失作为参考时，审计跟踪会变得有点棘手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
于 2015-01-02T04:09:15.737 回答