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

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 に答える