Public Sub ErrorLog(ErrorNumber As Long, ObjectName As String, ProcedureName As String, _
dblNoteNumber As Double, txtNote250 As String, conn As ADODB.Connection)
On Error GoTo Err_ErrorLog
Dim lngLastErrorId As Long
Dim rst As ADODB.Recordset
Set rst = New ADODB.Recordset
rst.ActiveConnection = conn
rst.CursorType = adOpenKeyset
rst.LockType = adLockPessimistic
rst.Open "SELECT * FROM tblErrorLog ORDER BY ErrorLogId WHERE False "
rst.AddNew
rst!ErrWhen = Now()
rst!ErrWho = CurrentUser()
rst!ErrNo = ErrorNumber
rst!ObjName = Trim(Left(ObjectName, 50))
rst!ProcName = Trim(Left(ProcedureName, 50))
rst!NoteNumber = dblNoteNumber
rst!NoteText = txtNote250
' If NewField added here then activate
' OnError Goto ErrorNew_Newfieldname
' rst!NewfieldName = value
rst.Update
rst.Close
Set rst = Nothing
Exit_ErrorLog:
Exit Sub
Err_ErrorLog:
If Err.Number = -2147217865 Then
' Table tblErrorLog does not exist
MsgBox "Please inform the administrator that the error log table does not exist." _
, , "THIS IS IMPORTANT"
Call MakeNewErrorTable(conn)
Resume
ElseIf Err.Number = 3265 Then
MsgBox "Please inform the administrator that the error log table has a field missing." _
, , "THIS IS IMPORTANT"
Resume Exit_ErrorLog
Else
MsgBox "Unknown Error in mdlErrorLog : " & Err.Description, , Err.Number
Resume Exit_ErrorLog
End If
'ErrorNew_Newfieldname:
'If Err.Number = 3265 Then
' ' Table tblErrorLog does not contain the most recent field list
' ' field NewField is missing
' ' So silently add this field to the table
' Call AddNewErrorTableField(NewField, DataType, Size, NewFieldContent,conn)
' Resume
'Else
' MsgBox "Unknown Error in mdlErrorLog : " & Err.Description, , Err.Number
' Resume Exit_ErrorLog
'End If
End Sub
Private Sub MakeNewErrorTable(conn As ADODB.Connection)
Dim tbl As New Table
Dim idx As New ADOX.Index
Dim cat As New ADOX.Catalog
Dim rst As ADODB.Recordset
Set rst = New ADODB.Recordset
rst.ActiveConnection = conn
rst.CursorType = adOpenKeyset
rst.LockType = adLockPessimistic
' Open the Catalog.
cat.ActiveConnection = conn
tbl.Name = "tblErrorLog"
tbl.Columns.Append "ErrorLogId", adInteger, 20
tbl.Columns.Append "ErrWhen", adDate
tbl.Columns.Append "ErrWho", adWChar, 50
tbl.Columns.Append "ErrNo", adInteger
tbl.Columns.Append "ObjName", adWChar, 50
tbl.Columns.Append "ProcName", adWChar, 50
tbl.Columns.Append "NoteNumber", adInteger
tbl.Columns.Append "NoteText", adWChar, 250
idx.Name = "ErrorIndex"
idx.Columns.Append "ErrorLogId"
idx.PrimaryKey = True
idx.Unique = True
tbl.Indexes.Append idx
cat.Tables.Append tbl
rst.Open "SELECT * FROM tblErrorLog"
rst.AddNew
rst!ErrorLogId = 1
rst!ErrWhen = Now()
rst!ErrWho = CurrentUser()
rst!ErrNo = 0
rst!ObjName = "mdlErrorLog"
rst!ProcName = "MakeNewErrorTable"
rst!NoteNumber = 0
rst!NoteText = "No Error Log Found - So new on created."
rst.Update
rst.Close
Set rst = Nothing
End Sub
Private Sub AddNewErrorTableField(strNewFieldName As String, intDataType As Integer _
, intSize As Integer, NewFieldContent As Variant, conn As ADODB.Connection)
Dim tbl As New Table
Dim idx As New ADOX.Index
Dim cat As New ADOX.Catalog
Dim rst As ADODB.Recordset
Set rst = New ADODB.Recordset
rst.ActiveConnection = conn
rst.CursorType = adOpenKeyset
rst.LockType = adLockPessimistic
' Open the Catalog.
cat.ActiveConnection = conn
tbl.Name = "tblErrorLog"
tbl.Columns.Append strNewFieldName, intDataType, intSize
cat.Tables.Append tbl
rst.Open "SELECT * FROM tblErrorLog"
rst.AddNew
rst!ErrorLogId = DMax("ErrorLogId", "tblErrorLog") + 1
rst!ErrWhen = Now()
rst!ErrWho = CurrentUser()
rst!ErrNo = 0
rst!ObjName = "mdlErrorLog"
rst!ProcName = "MakeNewErrorTable"
rst!NoteNumber = 0
rst!NoteText = "New field " & strNewFieldName & " added to the table."
rst(strNewFieldName) = NewFieldContent
rst.Update
rst.Close
Set rst = Nothing
End Sub
Public Function GetLocalErrorTableContents(rst As ADODB.Recordset) As ADODB.Recordset
On Error GoTo Err_GetLocal
Set rst = New ADODB.Recordset
rst.ActiveConnection = CurrentProject.Connection
rst.CursorType = adOpenKeyset
rst.LockType = adLockPessimistic
rst.Open "SELECT * FROM tblErrorLog"
Set GetLocalErrorTableContents = rst
' rst.Close
Exit_GetLocal:
Exit Function
Err_GetLocal:
If Err.Number = -2147217865 Then
MsgBox "The ErrorLog table is missing from UtilitiesCardWeb.mde" _
& vbCrLf & "Please inform your system administrator", , "This is important"
Else
' Do one's own error log call
End If
Resume Exit_GetLocal
End Function
