未绑定表单/文本框的审计跟踪

Question

我一直在寻找有关如何在我的 access 2010 数据库中实施审计跟踪的方法。有很多解决方案在绑定表单时效果很好，但是我有几个未绑定的表单并执行我希望对其进行审计跟踪的某些关键功能（由于必须根据不同的表编辑不同的表，它们是未绑定的用户输入、通过 VB 和 SQL 脚本执行的功能，因此将它们绑定到表将不起作用）。但是，如果不进行数周和数周的自定义编码，对于这种类型的审计似乎没有简单的解决方案。有人对如何做到这一点有任何想法吗？有没有一种无需绑定表单即可审核所有活动的方法？难道我不能只使用代码来监控表格的变化，而不必查看表单背面的代码吗？

Answer 1

我最近做了这个！

每个表单都有将更改写入表的代码。 当您丢失 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 Resume Next 'On Error GoTo Err_Handler
    Else
        On Error GoTo 0
    End If

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

    For Each ctl In Me.Detail.Controls
        If ctl.ControlType = acTextBox Or ctl.ControlType = acComboBox Then
            If ctl.Name <> "DateUpdated" Then
                If Nz(ctl.Value) <> Nz(ctl.OldValue) Then
                    If Me.NewRecord Then
                        With rst
                            .AddNew
                            !DateTimeMS = GetTimeUTC()
                            !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
                            !DateTimeMS = GetTimeUTC()
                            !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
        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)

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

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