CRUD Error with ADO - vba

Question

I am in the process of developing an Access 2016 database that has local tables. It will be migrated to SQL Server in future so I am using ADO for data processing.
While testing earlier, my error processing procedure failed to perform a log insert immediately after an error was trapped in the following test CRUD procedure.
Public Function updateTransportRate(lngOrigin As Long, lngDestination As Long, dblRate As Double) As Boolean
' check if global error handling is enabled ->
If glbErrorHandling Then On Error GoTo Error_Handler
' declarations ->
Dim strSQL As String
Dim strGUID As String
Dim cnn As ADODB.Connection
Set cnn = CurrentProject.Connection
Dim p_lRowsUpdated as Integer
strSQL = "UPDATE tbl_transport " & _
"SET rate=" & dblRate & ", modify_dtm=Now(), modify_user ='" & Application.CurrentUser & "' " & _
"WHERE origin=" & lngOrigin & " AND destination=" & lngDestination & ""
With cnn
.BeginTrans
.Execute strSQL, p_lRowsUpdated, dbFailOnError
If Err.Number <> 0 Then
.RollbackTrans
GoTo Error_Handler
Else
.CommitTrans
If glbDebugMode Then
Debug.Print "Records Updated : " & p_lRowsUpdated
End If
If p_lRowsUpdated > 0 Then updateTransportRate = True Else updateTransportRate = False
If glbLogApplicationActivity = True And p_lRowsUpdated > 0 Then
Call addActivityLog(SystemLogType.UpdateRecord, "Updated route " & lngOrigin & " -> " & lngDestination & " with rate: " & dblRate & " in tbl_transport")
End If
End If
End With
Error_Handler_Exit:
On Error Resume Next
Exit Function
Error_Handler:
If Err.Number <> 0 Then
If glbDebugMode Then
Select Case DebugOption("Error # " & Err.Number & " was generated by " & Err.Source & " (" & Err.Description & ")")
Case vbAbort, vbIgnore
ProcessError Err.Number, Err.Description, , , "Module", "MAINTENANCE", "Function", "updateTransportRate", Erl, True
Case vbRetry
Stop: Resume 0
End Select
Else
ProcessError Err.Number, Err.Description, , , "Module", "MAINTENANCE", "Function", "updateTransportRate", Erl, True
End If
End If
Resume Error_Handler_Exit
End Function
Below procedure is used in the above error handler to capture response only while in debug mode:
Public Function DebugOption(sErrorMessage As String) As Integer
DebugOption = MsgBox("" & sErrorMessage & "" _
& vbCrLf & "Abort - Stop" _
& vbCrLf & "Retry - Debug (then press F8 twice to show error line)" _
& vbCrLf & "Ignore - Continue with next line", _
Buttons:=vbAbortRetryIgnore Or vbCritical Or vbDefaultButton2, Title:=CurrentDb.Properties("AppTitle"))
End Function
Debug prompt message for testing only:
Below is my error processing procedure which accepts a number of parameters and writes the result to a log file:
Public Sub ProcessError(Optional strErrNumber As String = vbNullString, _
Optional strErrDescription As String = vbNullString, _
Optional intErrSeverity As Integer = 0, _
Optional strErrState As String = vbNullString, _
Optional strErrModuleType As String = vbNullString, _
Optional strErrModuleName As String = vbNullString, _
Optional strErrProcedureType As String = vbNullString, _
Optional strProcedureName As String = vbNullString, _
Optional strErrLineNo As String = vbNullString, _
Optional blnDisplay As Boolean = True)
' declarations ->
Dim strGUID As String
Dim strSQL As String
Dim cnn As ADODB.Connection
Set cnn = CurrentProject.Connection
Dim tmpString As String
' build string ->
tmpString = "Error # " & strErrNumber & " (" & strErrDescription & ") on line " & strErrLineNo & " in procedure " & strProcedureName & " of " & strErrProcedureType & " in " & strErrModuleType & " " & strErrModuleName & ""
If glbDebugMode Then Debug.Print tmpString
' check if error logging is enabled ->
If glbErrorLogging Then
' write error log to table ->
strGUID = CreateGuid
' insert log into error table ->
strSQL = "INSERT INTO system_error_log (error_user, error_number, error_description, error_severity, error_state, " & _
"error_module_type, error_module_name, error_procedure_type, error_procedure_name, " & _
"error_line, error_message, rowguid) " & _
"VALUES('" & Application.CurrentUser & "', '" & strErrNumber & "', '" & strErrDescription & "', " & intErrSeverity & ", '" & strErrState & "', " & _
" '" & strErrModuleType & "', '" & strErrModuleName & "', '" & strErrProcedureType & "', '" & strProcedureName & "', " & _
" '" & strErrLineNo & "', '" & Replace(tmpString, "'", "''") & "', '" & strGUID & "')"
cnn.Execute strSQL, , dbFailOnError **<---- FAILS HERE**
End If
End Sub
Why would the above error processing procedure fail on cnn.Execute strSQL, , dbFailOnError and then display the same error message from earlier CRUD procedure?
cnn.Execute error message:
Perhaps I am missing something simple here so hopefully someone can point me in the right direction.
Edit with new source code based on changes for review:
Public Function updateRoutePairRate(lngFromLocationNumber As Long, lngToLocationNumber As Long, dblRate As Double) As Boolean
If glbErrorHandling Then On Error GoTo Error_Handler
Dim prm_FromLocationNumber As ADODB.Parameter
Dim prm_ToLocationNumber As ADODB.Parameter
Dim prm_Rate As ADODB.Parameter
strSQL = "UPDATE tbl_transport " & _
"SET PalletRate =?, EffectiveDTS =Now(), LastUpdateUserID ='" & Application.CurrentUser & "' " & _
"WHERE FromLocNo=? AND ToLocNo=?"
' set connection and command objects ->
Set cnn = CurrentProject.Connection
Set cmd = New ADODB.Command
With cmd
' create and append parameters ->
Set prm_Rate = .CreateParameter("PalletRate", adDouble, adParamInput, , dblRate)
.Parameters.Append prm_Rate
Set prm_FromLocationNumber = .CreateParameter("FromLocNo", adInteger, adParamInput, , lngFromLocationNumber)
.Parameters.Append prm_FromLocationNumber
Set prm_ToLocationNumber = .CreateParameter("ToLocNo", adInteger, adParamInput, , lngToLocationNumber)
.Parameters.Append prm_ToLocationNumber
.Parameters.Refresh
For Each param In cmd.Parameters
Debug.Print param.Name, param.Value
Next
.ActiveConnection = cnn ' set the connection
.CommandText = strSQL ' set command text to SQL
.CommandType = adCmdText ' set command type
.Execute p_lRowsUpdated ' execute command
End With
If p_lRowsUpdated > 0 Then updateRoutePairRate = True Else updateRoutePairRate = False
End With
Error_Handler_Exit:
On Error Resume Next
Set cnn = Nothing
Set cmd = Nothing
Exit Function
Error_Handler:
If Err.Number <> 0 Then
If glbDebugMode Then
Select Case DebugOption("Error # " & Err.Number & " was generated by " & Err.Source & " (" & Err.Description & ")")
Case vbAbort, vbIgnore
ProcessError Err.Number, Err.Description, , , "Module", "MAINTENANCE", "Function", "updateRoutePairRate", Erl, True
Case vbRetry
Stop: Resume 0
End Select
Else
ProcessError Err.Number, Err.Description, , , "Module", "MAINTENANCE", "Function", "updateRoutePairRate", Erl, True
End If
End If
Resume Error_Handler_Exit
End Function