Audit trail code not picking up combobox list changes - vba

I have looked at this post: Saving changes to a multivalued ComboBox via AuditTrail
And tried to take tidbits and put it into my code, but it just didn't work! I am not really great at SQL but I need to get this done. Here is my code and it works for textboxes, but can someone tell me exactly where and exactly what to put what I need for my combobox dropdown list changes?
Thanks in advance!!
Function LogChanges(lngID As Long, Optional strField As String = "")
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim varOld As Variant
Dim varNew As Variant
Dim strFormName As String
Dim strControlName As String
varOld = Screen.ActiveControl.OldValue
varNew = Screen.ActiveControl.Value
strFormName = Screen.ActiveForm.NAME
strControlName = Screen.ActiveControl.NAME
Set dbs = CurrentDb()
Set rst = dbs.TableDefs("ztblDataChanges").OpenRecordset
With rst
.AddNew
!FormName = strFormName
!ControlName = strControlName
If strField = "" Then
!FieldName = strControlName
Else
!FieldName = strField
End If
!RecordID = lngID
!UserName = Environ("username")
If Not IsNull(varOld) Then
!OldValue = CStr(varOld)
End If
!NewValue = CStr(varNew)
.Update
End With
'clean up
rst.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing
End Function

You can't get the values of multi-valued fields using .Value and .OldValue. These properties always return Null. As far as I know, there's no reliable way to get the old value (also, a proper audit trail doesn't need an old value, since the old value is the previously added new value if everything gets audited properly).
When only saving the new values, and if you're saving them into a text field and not a multivalued field, you could use the following:
Use this function to get a string value for all selected items:
Public Function JoinMVF(MVFControl As Control, Optional Delimiter As String) As String
Dim i As Variant
For Each i In MVFControl.ItemsSelected
JoinMVF = JoinMVF & MVFControl.ItemData(i) & Delimiter
Next i
End Function
And then, adjust your recordset piece to the following:
With rst
.AddNew
!FormName = strFormName
!ControlName = strControlName
If strField = "" Then
!FieldName = strControlName
Else
!FieldName = strField
End If
!RecordID = lngID
!UserName = Environ("username")
If Not IsNull(varOld) Then 'varOld will always be Null for a multi-valued field
!OldValue = CStr(varOld) 'Thus this will never get called
End If
'Add some If multivalued field then
!NewValue = JoinMVF(Screen.ActiveControl, "; ")
.Update
End With

Related

How to check efficient whether a recordset value isnull before passing it to a called function?

I have a sub which creates a recordset. A function is called with values from the recordset. The goal is to use multiple values from the recordset, however, there is a possibility that a recordset value is null, then the function call will result in an error: "Invalid use of Null". To handle this error, each time the recordset value is checked for null values, if it is null, it will be replaced with an empty string. However, the way I have programmed this feels very inefficient, even more when later on more than ten parameters should be checked. Is there a way to do this more efficiently?
I have skipped the last part off the code as this is not necessary to understand my question. I've replaced it with ......... If needed, I will edit and provide full code.
Sub CallFunctionWithArray()
Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim arrValues(1 To 3) As Variant
Set conn = New ADODB.Connection
conn.Open "provider=Microsoft.JET.OLEDB.4.0;Data Source=" & CurrentProject.Path & "\Northwind.mdb"
Set rst = New ADODB.Recordset
rst.Open "SELECT * FROM CustomersCopy", conn, adOpenForwardOnly, adLockReadOnly, adCmdText
If Not (rst.EOF And rst.BOF) Then
rst.MoveFirst
Do Until rst.EOF = True
If IsNull(rst![CompanyName]) Then
arrValues(1) = ""
Else
arrValues(1) = rst![CompanyName]
End If
If IsNull(rst![DateTest]) Then
arrValues(2) = ""
Else
arrValues(2) = rst![DateTest]
End If
If IsNull(rst![INTTest]) Then
arrValues(3) = ""
Else
arrValues(3) = rst![INTTest]
End If
Call ReturnValuesOfArray(arrValues(1), arrValues(2), arrValues(3))
.........
End Sub
Function ReturnValuesOfArray(ByVal ValueOne As String, ByVal ValueTwo As String, ByVal ValueThree As String)
Debug.Print "Waarde variabele 1: " & ValueOne
Debug.Print "Waarde variabele 2: " & ValueTwo
Debug.Print "Waarde variabele 3: " & ValueThree
End Function
There is no problem with the code, it does what it's supposed to do. However, I will be passing many more parameters to the function when this is going to be really used.
You could loop through the fields of your Recordset instead of hard coding for every field. Using your code as a starting point, it could look something like this:
Private Sub Test()
Dim rst As ADODB.Recordset
Dim i As Integer
If Not (rst.EOF And rst.BOF) Then
rst.MoveFirst
Do Until rst.EOF = True
For i = 0 To rst.Fields.Count - 1
If IsNull(rst.Fields(i).Value) Then
arrValues(i) = ""
Else
arrValues(i) = rst.Fields(i).Value
End If
Next
Loop
End If
End Sub
Incorporating the ideas presented by #HansUp and #Mathieu Guindon, the code is even shorter:
Private Sub Test()
Dim rst As ADODB.Recordset
Dim i As Integer
Do Until rst.EOF
For i = 0 To rst.Fields.Count - 1
arrValues(i + 1) = Nz(rst.Fields(i).Value, "")
Next
Loop
End Sub
The rest of your code can be simplified, too, while allowing for any number of parameters:
Function ReturnValuesOfArray(ByVal Values As Variant)
Dim i As Integer
For i = LBound(Values) To UBound(Values)
Debug.Print "Waarde variabele " & i & ": " & Values(i)
Next
End Function
The Nz Function does what I think you want.
arrValues(1) = Nz(rst![CompanyName], "")
arrValues(2) = Nz(rst![DateTest], "")
arrValues(3) = Nz(rst![INTTest], "")

How to fix '438 - Object Doesn't Support Property or Method Error'

I have included an audit trail code to be called to 2 different forms in my access database. The code works fine for one of the forms but in the other form it produces a 438 error.
-The same parameter is used to call the code in both forms
-The debugger highlights this line : 'If Nz(ctl.Value) <> Nz(ctl.OldValue) Then
-I have attempted to comment out the code which calls the procedure and the problem appears to be with the parameter "SingleName"
-I have checked both the Control Source and Name for the textbox and both appear correct.
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_AuditTrail", cnn, adOpenDynamic,
adLockOptimistic
datTimeCheck = Now()
strUserID = Environ("USERNAME")
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.Number & Err.Description
Resume AuditChanges_Exit
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
If Me.NewRecord Then
Call AuditChanges("SingleName", "NEW")
Else
Call AuditChanges("SingleName", "EDIT")
End If
End Sub
The BeforeUpdate event of the form is supposed to call the procedure and send any changes, deletions or additions to TBL_AuditTrail.
After the data is inputted and I attempt to save, the 438 error occurs.
The information is still sent to the table (TBL_AuditTrail)
An unbound control doesn't have an OldValue property. You could check for that:
If ctl.ControlSource <> "" Then
![OldValue].Value = ctl.OldValue
Else
' Skip unbound control.
End If
Without seeing the three forms in question, I can only say that something is different on Screen.ActiveForm.Controls(IDField) field. I would compare the properties of all three fields to see how the one that is failing is different.

Access 2013 AuditTrail table showing GUID as chinese symbols

I have an audit trail table setup with an MS Access form that works although the ID (PK) is a GUID and when the data shows in my AuditTrail table it shows as Chinese characters. I can't work out why its not showing the actual ID.
In my BeforeUpdate event I have the following code which helps but not 100%:
Option Compare Database
Option Explicit
Private Sub Form_BeforeUpdate(Cancel As Integer)
On Error GoTo errHandler
If Me.NewRecord Then
Call AuditChanges("ID", "NEW")
Else
Call AuditChanges("ID", "EDIT")
End If
Exit Sub
errHandler:
MsgBox "Error " & Err.Number & ": " & Err.Description & " in " & _
VBE.ActiveCodePane.CodeModule, vbOKOnly, "Error"
End Sub
'I am using this code to for the AuditChanges
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 = Environ("USERNAME")
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
![FormName] = Screen.ActiveForm.Name
![RecordID] = Screen.ActiveForm.Controls(IDField).Value
![FieldName] = ctl.ControlSource
![OldValue] = ctl.OldValue
![NewValue] = ctl.Value
![UserID] = strUserID
![DateTime] = datTimeCheck
.Update
End With
End If
End If
Next ctl
Case Else
With rst
.AddNew
![DateTime] = datTimeCheck
![UserID] = 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
Although the ID is not showing correctly. I tried using StringFromGUID but this throws an error of cannot find the field. Example of GUID is {EF95C08E-D344-42B3-B678-2A64A50366DE}.
I hope someone can help although this is probably the wrong way of doing this it is the only way I have managed so far. Thanks.
The problem is that Application.StringFromGUID takes a byte array, and you've stored the bytes of your GUID as a string.
Access uses UTF-16 to store strings. Because a large fraction of two-byte UTF-16 characters are Chinese, you often get Chinese characters if you display random bytes as a string.
The following code casts them back to a bytearray, and then calls StringFromGUID. I've tested it on Access 2016 with default locale settings.
Public Function StringFromStringGUID(strGUIDBytes As String) As String
If Len(strGUIDBytes) = 8 Then
Dim bytes() As Byte
bytes = strGUIDBytes
StringFromStringGUID = Application.StringFromGUID(bytes)
Else
'Invalid string, GUID = 16 bytes, Access stores UTF-16 strings = 2 bytes per character
End If
End Function
You can use this in queries/VBA to cast those strings back to GUIDs

VBA Access - How to return max/min from multiple fields

I need help with some VBA code in Microsoft Access that will produce the maximum/minimum values for each of the fields below and return with their corresponding case attached
Force Table
case Flxmax Flxmin Frxmax Frxmin
hs00p16010od 582.24 666.81 796.44 -451.15
hs00p16015od 878.7 878.7 1096.3 -500.36
hs00p16020od 1071.95 1071.9 1281.2 -743.05
hs00p16025od 1186.65 1186.6 1397.8 -959.36
Desired Output
Field Force Case
Flxmax 1186.65 hs00p16025od
Flxmin 666.81 hs00p16010od
Frxmax 1397.8 hs00p16025od
Frxmin -959.36 hs00p16025od
In addition, if there are identical max/min values in the table I need to pick just one in the results.
There are 30 additional fields to the ones shown above. I believe that I have to loop through each field till I reach the end and record the max/min row, but I'm unsure how to write this code. Any help would be great.
Current Code
Public Sub Max()
Dim sqlStatement As String
Dim rs1 As Object
Dim rs2 As Object
Dim fld As Field
Dim strName As String
Dim maximum As Long
Dim minimum As Long
sqlStatement = "SELECT * FROM Force;"
Set rs1 = CurrentDb().OpenRecordset(sqlStatement)
sqlStatement = "SELECT * FROM Results;"
Set rs2 = CurrentDb().OpenRecordset(sqlStatement)
rs2.AddNew 'Add new record to result table
'Field order to loop though: max, min, skip, max, min, skip...where skip implies a skipped field
For Each fld In rs1.Fields
With rs1
maximum = DMax(fld, Force)
'Write onto results tables
End With
Next fld
rs2.Update 'Update results table
Set rs1 = Nothing
Set rs2 = Nothing
End Sub
You are quite close. What basically is missing is that every min/max field value must be added/updated separately to the target table.
Revised Code
Public Sub Max()
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim fld As DAO.Field
Dim newvalue As Long
Dim newfield As String
Dim newcase As String
Dim sqlStatement As String
Set db = CurrentDb
sqlStatement = "SELECT * FROM Force;"
Set rs1 = db.OpenRecordset(sqlStatement)
sqlStatement = "SELECT * FROM Results;"
Set rs2 = db.OpenRecordset(sqlStatement)
For Each fld In rs1.Fields
rs1.MoveFirst
newfield = fld.Name
If newfield <> "case" Then
newvalue = rs1(newfield).Value
While Not rs1.EOF
If Right(newfield, 3) = "min" Then
If newvalue > rs1(newfield).Value Then
newvalue = rs1(newfield).Value
newcase = rs1("Case").Value
End If
ElseIf Right(newfield, 3) = "max" Then
If newvalue < rs1(newfield).Value Then
newvalue = rs1(newfield).Value
newcase = rs1("Case").Value
End If
End If
rs1.MoveNext
Wend
rs2.AddNew
rs2!Field.Value = newfield
rs2!Force.Value = newvalue
rs2!Case.Value = newcase
rs2.Update
End If
Next fld
Set fld = Nothing
Set rs1 = Nothing
Set rs2 = Nothing
Set db = Nothing
End Sub
This is air code and I don't have test data. You may need to add some error handling.

VBA function to a field name

I have the same copy of a function in many forms that does exactly the same job. What changes in them is a field name. So the reason I keep it local is I don't know how I would refer to a particular field by name in a referenced form. This is the function:
Private Function getNewXNo(ByRef theForm As Form, ByVal strCode As String) As String
Dim rs As DAO.Recordset
Dim maxNo As Long
Dim aNo As Long
Set rs = theForm.RecordsetClone
maxNo = 0
If rs.RecordCount <> 0 Then
rs.MoveFirst
Do While Not rs.EOF
aNo = CLng(Right(Nz(rs!applicationNo, strCode & "0000"), 4))
If aNo > maxNo Then
maxNo = aNo
End If
rs.MoveNext
Loop
End If
getNewXNo = strCode & Format(maxNo + 1, "
Set rs = Nothing
End Function
There are a lot of instances when I have to generate new codes, such as BB001, BB002, APP001, APP002, etc. The function reads all existing codes from a field in the referenced form and based on that creates a new one. Is there any way I can send a field name to a global function, such as
aNo = CLng(Right(Nz(rs!varThatContainsAFieldName, strCode & "0000"), 4))
Thanks
You can access a field in a recordset like this:
rs("fieldname")
So you could make the field name a parameter for your function.