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分配给日志条目。这对于查看与特定项类型相关的单个条目（例如订单，客户，StockItem等）非常有用。

它被称为：

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

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

1 个答案: