Generic Error Handler and Error Log Table

A rather simple routine, to log errors.

First routine, extracts all pertinant information,
that will help, analyse and correct the error.

Then, all above data, will be appended to an "ErrorLog" table.

Then generic message will be displayed to user,
expressing the fact, that an error has occured.
(no need for msgBox, in every error routine).

Then a general clean-up follows,
(as much as can be foreseen, without causing errors...
closing objects, that aren't open etc...)
Otherwise, more specific clean-up should be done,
in every routine.

If ErrorTable does not exist, second routine is called,
which creates the "tblErrorLog".
Then, first routine, attempts to run the append query again.

Third routine, simply creates a few errors, to show functionality, of the above mentioned, two routines.
And, how to call Generic error handler,from every procedure.
Pay heed to colored notes, at bottom.

Hope this faciltates creating an error log for others,
or at least, offers a few ideas.
Good Luck!

PS, I use "Error handler builder from Zada Solutions"
www.zada.com.au, to place a custom error handler,
in every procedure. This 3rd party utility, has the ability,
to enter each produre name as an argument,
into my ErrorLog procedure.
As of yet, I can't do this on my own.
MZ-Tools utility, adds line numbers to every procedure
in project. VERY HELPFULL, to find where error occured!!!
***When wrapper is called, from each procedure,
the arguments are different depending on whether it's
a Form Class, or Standard Module.
Examples are Below.



___________________________________________________________
Sub ErrorLog(lngNumber As Long, _
strDesc As String, _
strSource As String, _
strProcedure As String, _
Optional strForm As String, _
Optional intLineNumber As Integer)
On Error GoTo xxx

Dim dteNow As Date, strComputer As String, strUser As String, strApp As String
Dim strCurrentObject As String, strModule As String, strLogOn As String, strCurrentProject As String
Dim strCurrentForm As String, strActiveControl As String, strUserName As String, objModule As Object

'strActiveControl = Screen.ActiveControl
'strCurrentForm = Screen.ActiveForm.Name
strApp = CurrentProject.FullName
dteNow = Now
strUser = Trim$(CurrentUser())
strCurrentObject = CurrentObjectName
Set objModule = VBE.ActiveCodePane.CodeModule
strModule = objModule.Name 'SORRY, not accurate...
strComputer = Environ("COMPUTERNAME") '6
strLogOn = replace(Environ("LOGONSERVER"), "\", "") '14
strUserName = Environ("UserName")
strCurrentProject = Left(CurrentProject.Name, Len(CurrentProject.Name) - 4)

MsgBox "Unexpected error N¦ " & lngNumber & vbCrLf & _
vbCrLf & strDesc, vbExclamation, strCurrentProject & " - " & strProcedure

CurrentProject.Connection.Execute _
"INSERT INTO tblErrorLog(txtErrDate,txtComputer,txtLogOn,txtApplication,txtErrNumber,txtErrSource," & _
"txtErrDescription,txtUser,txtModule,txtProcedure,txtCurrentObject, txtForm)" & _
"VALUES(#" & dteNow & "#,'" & strComputer & "','" & strLogOn & "','" & strApp & _
"'," & lngNumber & ",'" & strSource & "'," & Chr(34) & strDesc & Chr(34) & ",'" & strUserName & _
"','" & strModule & "','" & strProcedure & "','" & strCurrentObject & "','" & strForm & "')"

xx:
Set objModule = Nothing
DoCmd.SetWarnings True
DoCmd.Hourglass False
DoCmd.Echo True
Exit Sub
xxx:
If Err = -2147217865 Then 'table does not exist
Call CreateErrorTable 'Create table
Resume 'try again to insert, error data
Else
MsgBox "Unexpected error - " & Err & vbCrLf & _
Error$, vbExclamation, strCurrentProject & " - ErrorLog"
Resume xx
End If
End Sub


___________________________________________________________
Sub CreateErrorTable()
On Error GoTo xxx
Dim SQL As String

SQL = "CREATE TABLE tblErrorLog (pkErrorID AUTOINCREMENT PRIMARY KEY , " & _
"txtErrDescription MEMO, " & _
"txtErrNumber INTEGER, " & _
"txtErrSource TEXT(50), " & _
"txtCurrentObject TEXT(50), " & _
"txtForm TEXT(50), " & _
"txtProcedure TEXT(50), " & _
"txtModule TEXT(50), " & _
"txtErrDate DATETIME, " & _
"txtUser TEXT(50), " & _
"txtLogOn TEXT(50), " & _
"txtComputer TEXT(50), " & _
"txtApplication MEMO); "

CurrentProject.Connection.Execute SQL, , 129

xx:
Application.RefreshDatabaseWindow
Exit Sub
xxx:
If Err <> -2147217900 Then 'ByPass table already exist, error
MsgBox Err & vbCrLf & Error$, , "CreateErrorTable"
End If
Resume xx
End Sub


_________________________________________________________
Sub TryErrorTable()
[color red]'From Standard Module[/color]
On Error GoTo xxx

Dim v As Integer, str As String

str = Date

v = 56098789 * 34
v = 56 / 0
Dim rec As New adodb.Recordset
rec.Open "SELECT * FROM tblNothing", CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly

CurrentDb.Execute "DELETE FROM tblNoWhere"

DoCmd.OpenForm "FrmNoWhere"

xx:
If rec.State = adStateOpen Then rec.Close
Set rec = Nothing
Exit Sub
xxx:
Call ErrorLog(Err, Error$, Err.Source, "Sub; TryErrorTable",,Erl)
[color red]DoEvents[/color]'remove, only used for example
[color red]Resume Next 'invoke the next error[/color]'remove, only for example
[color blue]Resume xx[/color]' keep this
End Sub

____________________________________________________
Private Sub cmdTotal_Click()
[color red]'Call From Form Class Module[/color]
10 On Error GoTo xxx
20 MsgBox 5/0
xx:
30 Exit Sub
xxx:
40 Call ErrorLog(Err, Error$, Err.Source, "Sub; cmdTotal_Click"[color red], Me.Name[/color],Erl)
50 Resume xx
60 End Sub