修改 Access VBA 以捕获表单中所做的更改

Question

我在网上找到了这段代码 (http://www.fontstuff.com/access/acctut21.htm) 来捕获对表格所做的更改。该代码适用于提供的示例数据库，但不适用于我的数据库。对于示例和我的数据库，更改是通过表单进行的，并由“更新前”表单属性中的事件过程触发。我没有收到任何错误，但没有任何内容写入审计表。我的表单与示例中的表单之间的一个区别是我的表单通过查询从多个表中提取数据，并且对多个表进行了更新。示例表单仅显示一张表中的字段，并且仅对一张表进行更新。

如何获取此代码来记录我的更改？

Option Compare Database
Option Explicit
Sub AuditChanges(IDField 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")
    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
                    ![RecordID] = Screen.ActiveForm.Controls(IDField).Value
                    ![FieldName] = ctl.ControlSource
                    ![OldValue] = ctl.OldValue
                    ![NewValue] = ctl.Value
                    .Update
                End With
            End If
        End If
    Next ctl
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

这是我用来创建审核日志的代码。它运行良好，可以将 ItemTypes 分配给日志条目。这对于查看与特定项目类型（例如订单、客户、库存项目等）相关的单个条目很有用。

调用者：

Private Sub Form_BeforeUpdate(Cancel As Integer)
On Error Resume Next
AuditLog Me, "Order", Me.ID
End Sub

功能代码

Public Sub AuditLog(frm As Form, ItemType As String, ItemID As Integer, Optional exControl As Variant)
Dim ctl As Control
Dim varBefore As Variant
Dim varAfter As Variant
Dim strControlName As String
Dim strSql As String
On Error Resume Next

For Each ctl In frm.Controls
With ctl
'Avoid labels and other controls with Value property.
If .ControlType = acTextBox Or acComboBox Or acCheckBox Then
If .Tag = 1 Then

Else
If IsOldValueAvailable(ctl) = True Then
    If Nz(.Value, "[Empty]") <> Nz(.OldValue, "[Empty]") Then
    varBefore = .OldValue
    varAfter = .Value
    strControlName = .Name
    strSql = "INSERT INTO [UserActivities] (UserID,Entry,[Field],OldValue,NewValue,Type,ItemID) " & _
    "Values ('" & userid & "','Value Change','" & strControlName & "','" & varBefore & "','" & varAfter & "','" & ItemType & "','" & ItemID & "');"

    CurrentDb.Execute strSql, dbFailOnError

 End If
    End If
    End If
End If
End With
Next
Set ctl = Nothing
Exit Sub

ErrHandler:
MsgBox err.Description & vbNewLine _
& err.Number, vbOKOnly, "Error"
End Sub

Answer 2

这个问题和this other StackOverflow answer基本一样。我将我们的解决方案基于链接中使用参数的解决方案，并将其更改为 ADO 命令。使用参数和 ADO 命令允许您使用 DAO 参数超过 255 个字符的限制，并且如果您最终尝试跟踪 RTF 字段，您将不会因为尝试将 HTML/markdown/whatever 解析为安全的 SQL 而感到头疼字符串（如果用户在您的表单中输入此类数据，也更能抵抗 SQL 注入攻击）。您会发现我为我们的旧值/新值使用了“longText”字段，因为这有助于使用备注字段和更可重用的字段。

在记录字段更改时，使用 ADO 命令与记录集相比要快几个数量级，因为除了插入数据之外，您无需执行任何操作。

注意以下几点：

1. 此解决方案需要链接表和字段。它不处理非链接字段的检测。
2. 此解决方案忽略以安全方式获取用户详细信息（用户名）。使用 Environ 变量不是很安全，但我放弃了它。
3. 我发现缓存命令以供以后使用会使命令的运行速度比每次构建命令快一个数量级。当您定期记录表单上的所有字段（例如，用于审核）时，这会产生很大的不同，而且不会占用太多内存或连接成本。
4. 我假设所有字段都是“文本”。情况可能并非如此，因此您需要更改字段类型以匹配正确的类型和大小。

代码：

Option Compare Database
Option Explicit

Private m_strUserID as String
Private m_StoredCMD as ADODB.Command

Private Property Get StrUserID as String
    If m_struserID = vbNullString then m_strUserID = Environ("USERNAME")
    StrUserID = m_struserID
End Property

Public Sub AuditChanges(ByRef FormToProcess as Access.Form, Byref RecordIDField as String)
    Dim TimeStamp as DateTime
    Dim CtrlCheck as Access.Control
    Dim RecordIDFieldCtrl as Access.Control
    Set RecordIDFieldCtrl = FormToProcess.Controls(RecordIDField)
    TimeStamp = Now()
    For Each CtrlCheck In FormToProcess
        If IsChanged(CtrlCheck) And CtrlCheck.Tag = "Audit" Then
            AddLogEntry (CtrlChanged, RecordIDFieldCtrl.Value)
        End If
    Next CtrlCheck
End Sub

Private Sub AddLogEntry (ByRef CtrlChanged as Control, ByRef RecordIDFieldCtrl as Access.Control)
    Dim TimeStamp as DateTime
    Dim adoCMD =  ADODB.Command
    TimeStamp = Now()
    If IsChanged(CtrlChanged) Then    ' Verify anything actually changed. Check twice because it doesn't cost anything.
        Set adoCMD = GetLogCommand ' Note, it will be much faster to put this into a module stored command, but 
        With If adoCMD 
            (.ActiveConnection.State And adStateOpen) <> adStateOpen Then .ActiveConnection.Open
            .Parameters("[pDateTime]") = TimeStamp
            .Parameters("[pUserName]") = StrUserID
            .Parameters("[pFormName]") = CtrlChanged.Parent.Name
            .Parameters("[pRecordID]") = RecordIDFieldCtrl.Value
            .Parameters("[pFieldName]") = CtrlChanged.Name
            .Parameters("[pNewValue]") = CtrlChanged.Value
            .Parameters("[pOldValue]") = CtrlChanged.OldValue
            .Execute
    End If
End Sub

Public Function GetLogCommand() As ADODB.Command
    Dim cnn as ADODB.Connection
    Dim SQLCommand as String

    If m_StoredCMD Is Nothing Then 
        ' Note: Verify these field type assumptions are correct and alter as needed.
        ' Note2: I use "LongText" Fields for values, because Access's VarChar Fields are limited to 255 charachters. 
        '        If you're using any
        SQLCommand = "PARAMETERS [pDateTime] DateTime, [pUserName] VARCHAR(255), " & _ 
                    "[pFormName] VARCHAR(255), [pRecordID] VARCHAR(255), [pFieldName] VARCHAR(255)," & _ 
                    "[pOldValue] LONGTEXT, [pNewValue] LONGTEXT;
                    INSERT INTO tblAuditTrail (DateTime,UserName,FormName,RecordID,FieldName,OldValue,NewValue) " & _ 
                    "VALUES ([pDateTime], [pUserName], [pFormName], [pRecordID], [pFieldName], [pOldValue], [pNewValue]); "
        Set m_StoredCMD = New ADODB.Command
        With m_StoredCMD
            Set .ActiveConnection = CurrentProject.Connection
            .CommandText = SQLString.GetStr
            .CommandType = adCmdText
            .Prepared = True
            .Parameters.Append .CreateParameter("[pDateTime]", adDBTimeStamp, adParamInput, 255)
            .Parameters.Append .CreateParameter("[pUserName]", adVarChar, adParamInput, 255)
            .Parameters.Append .CreateParameter("[pFormName]", adVarChar, adParamInput, 255)
            .Parameters.Append .CreateParameter("[pRecordID]", adVarChar, adParamInput, 255)
            .Parameters.Append .CreateParameter("[pFieldName]", adVarChar, adParamInput, 255)
            .Parameters.Append .CreateParameter("[pNewValue]", adLongVarChar, adParamInput, 63999)
            .Parameters.Append .CreateParameter("[pOldValue]", adLongVarChar, adParamInput, 63999)
        End With
    End If

    Set GetLogCommand = m_StoredCMD
End Function

Public Function IsChanged(ByRef CtrlChanged as Control) As Boolean
    ' There are a lot of ways to do this, but this keeps code clutter down, and lets you 
    ' alter how you determine if a control was altered or not.
    ' As this is written, it will ONLY work on bound controls in bound forms.
    IsChanged = ((CtrlChanged.OldValue <> CtrlChanged.Value) Or (IsNull(CtrlChanged.OldValue) = Not IsNull(CtrlChanged.Value)))
End Function