Audit Changes to Variant Types - ms-access

In Microsoft access, I am creating an audit table that tracks changes to the DB. We have it working for data points that are text boxes. However, we track a few categorical (variant) data points for each item in the db. The audit log doesn't seem to work for just this one specifically. I believe this is because .oldvalue doesn't work on variants, but I don't know what the alternative is.
Basically when I make a change, and I go to the audit log, oldvalue == newvalue if I change one of the variants. So if I change the "type" of the data point from financial to managerial, old == managerial and new == managerial in my audit log.
I have attached the code below in hopes that someone smarter than me can help me figure this one out.
Thank you very much in advance.
after doing research I found no alternative to .oldvalue in access.
Select Case UserAction
Case "EDIT"
For Each ctl In Screen.ActiveForm.Controls
If ctl.Tag = "Audit" Then
If (TypeName(ctl.Value) <> "Variant()") 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
If (TypeName(ctl.Value) = "Variant()") Then
With rst
.AddNew
![DateTime] = datTimeCheck
![UserName] = strUserID
![FormName] = Screen.ActiveForm.Name
![Action] = UserAction
![RecordID] = Screen.ActiveForm.Controls(IDField).Value
![FieldName] = ctl.ControlSource
![OldValue] = Join(ctl.OldValue, ",")
![NewValue] = Join(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
I expect in my audit log for oldvalue to be financial and newvalue to be managerial. However, both old and new are managerial .Leading me to believe that .oldvalue isn't functioning.

Related

My Audit Trail Script Isn't Working

I'm using the below code to audit my forms for changes. It works perfectly when I use "MBRID" which is the ID field on tbl_MBR. However, when I use "IMID" which is the ID field on tbl_ItemMaster, I get an error: can't find the field 'IMID' referred to in your expression. Any idea why IMID cannot be found?
Private Sub Form_AfterDelConfirm(Status As Integer)
If Status = acDeleteOK Then Call AuditChanges("IMID", "DELETE")
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
If Me.NewRecord Then
Call AuditChanges("IMID", "NEW")
Else
Call AuditChanges("IMID", "EDIT")
End If
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
Set cnn = CurrentProject.Connection
Set rst = New ADODB.Recordset
rst.Open "SELECT * FROM tbl_AuditChanges", cnn, adOpenDynamic, adLockOptimistic
datTimeCheck = Now()
strUserID = Environ("USERNAME")
Select Case UserAction
Case "EDIT"
For Each ctl In Me.Controls
Debug.Print ctl.Name
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
The answer was a little hidden but I found it. The field IMID wasn't in the query associated with the subform. Therefore, when the code looked for "IMID" it was not found.
Adding "IMID" to the query solved the problem.

Query code generating Invalid Use Of Null

My code is generating an Invalid Use Of Null and I am not seeing the issue. When I compile the code, I do not get an error, but when I run and debug it, the error occurs at strRESMILE = rs("RESMILE").
Any thoughts? I can upload the database if need be.
Sub COMPARE()
On Error GoTo err_COMPARE
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Dim strHold As String
Dim strRESMILE As String
Dim strRESMONTH As String
Dim dblMILEAGEHold As Double
Dim dblDATEHold As Double
Set db = CurrentDb
strSQL = "SELECT * FROM TABLE3"
Set rs = db.OpenRecordset(strSQL)
With rs
' If Not .BOF And Not .EOF Then
' .MoveLast
' .MoveFirst
If Not .BOF Then
strHold = rs("VIN")
dblMILEAGEHold = rs("MILES")
.Edit
rs("RESMILE") = ""
.Update
.MoveNext
'While (Not .EOF)
Do Until .EOF
.Edit
If rs("VIN") = strHold Then
'do comparison
If rs("MILEAGE") > rs("MILES") Then
rs("RESMILE") = "Y"
Else
rs("RESMILE") = "N"
End If
End If
.Update
strHold = rs("VIN")
strRESMILE = rs("RESMILE")
.MoveNext
' Wend
Loop
End If
End With
Set db = CurrentDb
strSQL = "SELECT * FROM TABLE3"
Set rs = db.OpenRecordset(strSQL)
With rs
If Not .BOF Then
strHold = rs("VIN")
dblDATEHold = rs("MONTHS")
.Edit
rs("RESMONTH") = ""
.Update
.MoveNext
Do Until .EOF
.Edit
If rs("VIN") = strHold Then
'do comparison
If rs("INSM") > rs("MONTHS") Then
rs("RESMONTH") = "Y"
Else
rs("RESMONTH") = "N"
End If
End If
.Update
strHold = rs("VIN")
dblDATEHold = rs("RESMONTH")
.MoveNext
Loop
End If
End With
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
MsgBox "Comparisons Completed!"
exit_COMPARE:
Exit Sub
err_COMPARE:
MsgBox Err.Description
Resume exit_COMPARE
End Sub
Handle the evident NULL in your [RESMILE] field by using Nz().
So change strRESMILE = rs("RESMILE") to strRESMILE = Nz(rs("RESMILE"))

Access VBA Looping Through Controls Shows Field Value As Control Name

I have a function that loops through all of the controls on a form. If the tag says "audit", it tracks the changes made to that field. It's worked fine until now. Now, it is throwing an error of "Operation is not supported for this type of object". When I turn off the error handling, and check the code, for some reason it is feeding the actual field VALUE in as the control name. Any help would be very much appreciated. Here's the code:
Dim rst As Recordset
Dim ctl As Control
Dim datTimeCheck As Date
Dim strUserID As String
Dim dbs As DAO.Database
Dim strSQL As String
Set dbs = CurrentDb
strSQL = "SELECT * FROM ChangeLog"
Set rst = dbs.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)
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
![ChangeTimeStamp] = datTimeCheck
![UserId] = strUserID
![FormName] = Screen.ActiveForm.Name
![LeadID] = Lead
![EstID] = Estimate
![EOINumber] = Order
![InstalID] = Install
![FieldName] = ctl.ControlSource
![FieldValueBeforeChange] = Nz(ctl.OldValue, "Blank")
![FieldValueAfterChange] = Nz(ctl.Value, "Blank")
.Update
End With
End If
End If
Next ctl
Not all controls have the ControlSource property such as command buttons, rectangles, and lines. Only data-driven objects like textboxes, checkboxes, comboboxes, listboxes would have this property. So, consider conditioning your search with the textbox ControlType. Hence, the challenge of looping through all form controls!
...
For Each ctl In Me.Form.Controls
If ctl.ControlType = acTextBox And _
ctl.Tag = "Audit" And _
Nz(ctl.Value) <> Nz(ctl.OldValue) Then
With rst
.AddNew
![ChangeTimeStamp] = datTimeCheck
![UserId] = strUserID
![FormName] = Screen.ActiveForm.Name
![LeadID] = Lead
![EstID] = Estimate
![EOINumber] = Order
![InstalID] = Install
![FieldName] = ctl.ControlSource
![FieldValueBeforeChange] = Nz(ctl.OldValue, "Blank")
![FieldValueAfterChange] = Nz(ctl.Value, "Blank")
.Update
End With
End If
Next ctl
It's a little bit late but I ran into the same issue... And I realize that this is the comparison that throws the error. If you set the oldvalue to a variable and the current value to a variable, comparing both variables is OK.
DO NOT WORK
If me.mycontrol.oldvalue <> me.mycontrol.value then
DO WORK
myvariableOld = me.mycontrol.Oldvalue
myvariableNew = me.mycontrol.Value
If myvariableOld <> myvariableNew then

Audit Trail for unbound forms/textboxes

I have been searching for days for ways on how to implement an audit trail in my access 2010 database. There are plenty of solutions out there that work great when the form is bound, but I have several forms that are unbound and perform certain critical functions I wish to have an audit trail on (they are unbound due to having to edit different tables depending on user input, functions performed through VB and SQL scripting, so binding them to a table would not work). But there seems to be no easy solutions on this type of auditing without doing weeks and weeks worth of custom coding. Does anyone have any ideas on how to do this? Is there a way to audit all activity without having to bind a form? Can't I just have code that monitors a table's changes without having to go though code on the back side of the forms?
I have recently done this!
Each form has code to write changes to a table.
The Audit Trail gets a bit tricky when you lose Screen.ActiveForm.Controls as the reference - which happens if you use a Navigation Form.
It is also using Sharepoint lists so I found that none of the published methods were available.
I (often) use a form in the middle as a display layer and I find it has to fire the Form_Load code in the next forms down the line as well.
Once they are open they need to be self sustaining.
Module Variable;
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

Access 2010 Audit Trail on SubForms

I am having trouble getting the code I found for an audit trail to work with sub forms. The origninal code is from http://www.fontstuff.com/access/acctut21.htm. I would rather stick to this code than using Allen Browne's code http://allenbrowne.com/appaudit.html. It seems to be a problem with Screen.ActiveForm.Controls. I have read that this does not work with sub forms. Is there a way I can alter this to audit a sub form in my database?
When I record the data in the sub form, I get the following error: Microsoft can't find the field "CalSubID" referred to in your expression."
In a module I have this code (this is just part of it that I think is having issues):
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
Then in my "before update" and "AfterDelConfirm" events for the subform I have (where "CalSubID" is the PK for the subform and this is what the main module code uses to track the changes):
-----------------------------------------------------------------------
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
-----------------------------------------------------------------------
Modified Code:
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
I'm presuming your error is with the line (it would help if you would verify):
![RecordID] = Screen.ActiveForm.Controls(IDField).Value
The issue as you've stated is that you can't access subform controls this way but must reference in this manner:
![RecordID] = Forms![main form name]![subform control name].Form![control name].Value
In your case, you need to first find the subform control name (presuming you only have 1 subform)
' 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
Now in your code when setting RecordID, you can do it like this:
' you should check that SubFormName is not empty before this next line...
![RecordID] = Forms![Screen.ActiveForm.Name]![SubformName].Form![IDField].Value
I have not tested this and I'm a bit rusty on Access, so take the concept and fix the syntax.
** UPDATE** - Here is the code I would try with the new information you have provided. I am presuming that the controls (e.g. the one with ctl.Tag = "Audit") are all on the subform
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
I actually have a much simpler solution. You need to pass the (sub)form object along to the main basAudit sub.
Now, becuase the subform is the one initiating the command, it will be passed along to basAudit sub instead of the ActiveForm (wich is the main form, not the subform).
Modify the basAudit module as followed:
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
Change the AfterDelConfirm sub as followed:
Private Sub Form_AfterDelConfirm(Status As Integer)
If Status = acDeleteOK Then Call AuditChanges("Site", "DELETE", Form)
End Sub
And last, change the BeforeUpdate sub as followed:
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
I have recently done this!
Each form has code to write changes to a table.
The Audit Trail gets a bit tricky when you lose Screen.ActiveForm.Controls as the reference - which happens if you use a Navigation Form.
It is also using Sharepoint lists so I found that none of the published methods were available.
I (often) use a form in the middle as a display layer and I find it has to fire the Form_Load code in the next forms down the line as well.
Once they are open they need to be self sustaining.
Module Variable;
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