My Audit Trail Script Isn't Working - ms-access

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.

Related

Audit Changes to Variant Types

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.

MS Access VBA : Pushing form information to web

The issue I am having is connect my Save_Record (suppose to save and push info) & btnExit (saves & exits) to push the information inputted on the form to be pushed out to the web database. The only way it will push the information is if I exit out, come back in and make a small change then it will push it out.
How can I achieve this without doing this?
Option Compare Database
Option Explicit
'-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**
Private Sub btnCancel_Click() '==**== undo changes
On Error Resume Next
RunCommand acCmdUndo
Err = 0
End Sub
'-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**
Private Sub btnExit_Click()
DoCmd.Close
End Sub
Private Sub cmdViewPDF_Click()
On Error GoTo Err_cmdViewPDF_Click
Dim stDocName As String
Dim stLinkCriteria As String
stDocName = "frm_Images"
DoCmd.OpenForm stDocName, , , stLinkCriteria
Exit_cmdViewPDF_Click:
Exit Sub
Err_cmdViewPDF_Click:
MsgBox Err.Description
Resume Exit_cmdViewPDF_Click
End Sub
'-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**
Private Sub Form_AfterUpdate()
'DoCmd.Save
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
[DT_MOD] = Now()
[MstrWinUser] = Forms!frFilter!txtWinUser
End Sub
'-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**
Private Sub MOREoperInfo_Click()
Dim DocName As String
Dim LinkCriteria As String
DoCmd.Save
DocName = "frmsearch"
DoCmd.OpenForm DocName, , , LinkCriteria
End Sub
'-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**
'Save record and close
Private Sub Save_Record_Click()
On Error GoTo Err_Save_Record_Click
[DT_MOD] = Now()
[MstrWinUser] = Forms!frmFilter!txtWinUser
'MsgBox "Saving frm_View"
'Save the record
'If there was a record already in txt box, we will assume it has been created in web
If Trim(txtEOCIncident.Value & vbNullString) = vbNullString Then
Me.txtEOCPushFlag = "0"
RunCommand acCmdSaveRecord
DoCmd.Save
Else
'SET EOC PUSH FLAG
Me.txtEOCPushFlag = "1"
RunCommand acCmdSaveRecord
DoCmd.Save
'TRY TO UPDATE WEB DATA
If (pushEOCData(Me.ID)) Then
'CLEAR PUSH FLAG AND SET PUSHDATE
Me.txtEOCPushFlag = "0"
Me.txtEOCPushDate = Now()
RunCommand acCmdSaveRecord
DoCmd.Save
End If
End If
Exit_Save_Record_Click:
Exit Sub
Err_Save_Record_Click:
MsgBox Error$
Resume Exit_Save_Record_Click
End Sub
'*** 08-20-13 New code. Creates PDF of the Report.
Private Sub btnSaveasPDF_Click()
On Error GoTo Err_btnSaveasPDF_Click
Dim db As Database, rs As Recordset
Dim vFN As String, vPATH As String, vFile As String
Dim blRet As Boolean
Dim stDocName As String
Dim strConstantName As String
stDocName = "rpt_Out"
'added 2014-09-02, MAB
strConstantName = "REPORT_FOLDER"
vPATH = Trim(DLookup("[ConstantValue]", "dbo_Constants", "[ConstantName] = '" & [strConstantName] & "'"))
If Forms!frm_View![DIST] = "1" Or Forms!frm_View![DIST] = "2" Or Forms!frm_View![DIST] = "3" Or Forms!frm_View![DIST] = "4" Then
vFN = Forms!frm_View![ID] & "_" & Forms!frm_View![Typeofreport] & "_" & Month(Now()) & "_" & Day(Now()) & "_" & Year(Now()) & "_" & Hour(Now()) & Minute(Now()) & ".pdf"
'vPATH = "\\...\...\Reports\"
vFile = vPATH & vFN
Else
MsgBox "Please enter your number." & vbCrLf & "It must be a single digit.", vbOKOnly Or vbInformation, "*****"
End If
'write to IMAGES
Set db = CurrentDb
Set rs = db.OpenRecordset("IMAGES")
rs.AddNew
rs!SPL_FILENAME = vFN
rs!SPL_ID = [Forms]![frm_View]![ID]
rs!SPL_MOD_DT = Format$(Now(), "mm/dd/yyyy")
rs!SPL_DOC_TYP = Forms!frm_View![DOC_TYP]
rs!SPL_FILELOC = vFile
rs!SPL_ACTIVE = "-1"
rs.Update
rs.Close
DoCmd.OpenReport "rpt_OUT", acViewPreview
DoCmd.OutputTo acReport, stDocName, acFormatPDF, vFile
MsgBox "An image of this report has been saved.", vbOKOnly Or vbInformation, "*****"
Exit_btnSaveasPDF_Click:
Exit Sub
Err_btnSaveasPDF_Click:
MsgBox Err.Description
Resume Exit_btnSaveasPDF_Click
End Sub
********************PUSHEOCDATA*******************************************
'* iSpillID is the value of SPILL_ID from Spills table for the
'* the record you want to update
'*
'*******************************************************************************
Public Function pushEOCData(iSpillID As Integer) As Boolean
Dim db As Database
Dim sSql As String
Dim strStoredProcSql As String
Dim qdef As DAO.QueryDef
Dim sEOCIncident As String
Dim rs As Recordset
Dim iEOCSpillID, iEOCMat1ID, iEOCMat2ID As Long
Dim iReturn As Integer
Dim dAmount1 As Double
Dim dAmount2 As Double
Dim sSpillResponse As String
Dim sMaterialResponse As String
Dim sEOCSpillID, sEOCMat1ID, sEOCMat2ID As String
Dim iFoundAt As Long
Dim iStart As Long
Dim sTemp As String
Dim bReturn As Boolean
Dim objSpillNode As IXMLDOMNode
Dim objMaterialsNodes As IXMLDOMNodeList
Dim objMaterialNode As IXMLDOMNode
pushEOCData = True
initWEBEoc
iEOCSpillID = -1
iEOCMat1ID = -1
iEOCMat2ID = -1
'RETRIEVE INCIDENT NUMBER FROM DATABASE and associated data
'from the database. Note: this is a stored procedure
Set db = CurrentDb
Set qdef = CurrentDb.CreateQueryDef("")
qdef.Connect = CurrentDb.TableDefs("usysWellHistory").Connect
qdef.ReturnsRecords = True
'
' This stored procedure is written to return a record set with
' fields named the same as in webeoc.
'
'strStoredProcSql = "EXEC RBDMS.SPILL_QUERY #N_SPILLID=" & iSpillID
strStoredProcSql = "{CALL RBDMS.SPILL_QUERY (" & iSpillID & ")}"
qdef.sql = strStoredProcSql
Set rs = qdef.OpenRecordset
'Check to see if the recordset actually contains rows
If Not (rs.EOF And rs.BOF) Then
rs.MoveFirst 'Unnecessary in this case, but still a good habit
sEOCIncident = rs!INCIDENTID_NUMBER
If Len(sEOCIncident) < 1 Then
pushEOCData = False
Exit Function
End If
'Get the data from webeoc.
'business rules say that we have to have data
'in webeoc to continue
iReturn = getSpillNode(sEOCIncident, objSpillNode)
If iReturn < 1 Then
'MsgBox "No WEBEoc data exists for EOC Incident: " & sEOCIncident
pushEOCData = False
Exit Function
End If
'grab the data id from the spill data, we will need this later to
'update the materials
sEOCSpillID = objSpillNode.Attributes.getNamedItem("dataid").Text
iEOCSpillID = CLng(sEOCSpillID)
If iEOCSpillID < 1 Then
pushEOCData = False
Exit Function
End If
bReturn = updateEOCSpillData(rs, objSpillNode)
If bReturn = False Then
pushEOCData = False
Exit Function
End If
dAmount1 = rs!AMOUNT1
dAmount2 = rs!AMOUNT2
'Get the materials records from webeoc for this incident number.
iResult = getMaterialNodes(sEOCSpillID, objMaterialsNodes)
If dAmount1 > 0 Then
'If webeoc has one or more materials records for the incident,
'grab the first record and update it with dbase values
If objMaterialsNodes.LENGTH > 0 Then
Set objSpillNode = objMaterialsNodes.Item(0)
'update materials
updateEOCMaterialData rs, objSpillNode, 1
Else
'insert materials
insertEOCMaterialData rs, 1, sEOCSpillID
End If
End If
If dAmount2 > 0 Then
'if webeoc has more than one materials record for the incident,
'grab the second record and update it.
If objMaterialsNodes.LENGTH > 1 Then
Set objSpillNode = objMaterialsNodes.Item(1)
'update materials
updateEOCMaterialData rs, objSpillNode, 2
Else
'insert materials
insertEOCMaterialData rs, 2, sEOCSpillID
End If
End If
Else
'MsgBox "No data needs to be pushed to webeoc for this spill."
pushEOCData = True
Exit Function
End If
rs.Close
End Function

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

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