PING: Tom (or anyone interested) - Error codes tables

[RD]

Below is code to produce two error code tables, one for vba errors and one for
Access/Jet errors. I got all this code from the web. I'm presenting it here as
I found it and make no guarantees. Beware of word wrap.

Regards,
RD


Function CreateErrorsTable() As Boolean
Dim dbs As Database, tdf As TableDef, fld As Field, idx As Index
Dim rst As Recordset, intCode As Integer, strErr As String

Const conAppObjErr = "Application-defined or object-defined error"

' Create Errors table with ErrorCode and ErrorString fields.
Set dbs = CurrentDb

On Error Resume Next
' Delete any existing Errors table.
dbs.TableDefs.Delete "Errors"

On Error GoTo Error_CreateErrorsTable
' Create table.
Set tdf = dbs.CreateTableDef("Errors")
' Create fields.
Set fld = tdf.CreateField("ErrorCode", dbInteger)
tdf.Fields.Append fld
Set fld = tdf.CreateField("ErrorString", dbMemo)
tdf.Fields.Append fld
dbs.TableDefs.Append tdf

' Create index.
Set idx = tdf.CreateIndex("ErrorCodeIndex")
Set fld = idx.CreateField("ErrorCode")
With idx
.Primary = True
.Unique = True
.Required = True
End With
idx.Fields.Append fld
tdf.Indexes.Append idx

' Open recordset on Errors table.
Set rst = dbs.OpenRecordset("Errors")
' Set recordset's index.
rst.Index = "ErrorCodeIndex"

' Show hourglass pointer.
DoCmd.Hourglass True

' Loop through error codes.
For intCode = 1 To 32767
On Error Resume Next
strErr = ""
' Attempt to raise each error.
Err.Raise intCode

' Check whether error is VBA, DAO, or Access error.
' If error is not a VBA error, the Description property
' of the Err object contains "Application-defined or object-defined
error".
If Err.Description <> conAppObjErr Then
strErr = Err.Description

' Use AccessError method to return descriptive string for
' DAO and Access errors.
ElseIf AccessError(intCode) <> conAppObjErr Then
strErr = AccessError(intCode)
End If

' If error number has associated descriptive string, add to table.
If Len(strErr) > 0 Then
' Add new record to recordset.
rst.AddNew
' Add error number to table.
rst!ErrorCode = intCode
' Add descriptive string to table.
rst!ErrorString.AppendChunk strErr
' Update record.
rst.Update
End If
Next intCode

DoCmd.Hourglass False
' Close recordset.
rst.Close
MsgBox "Errors table created."
' Show new table in Database window.
RefreshDatabaseWindow

CreateErrorsTable = True

Exit_CreateErrorsTable:
Exit Function

Error_CreateErrorsTable:
MsgBox Err & ": " & Err.Description
CreateErrorsTable = False
Resume Exit_CreateErrorsTable
End Function



Public Function AccessAndJetErrorsTable() As Boolean

Dim dbs As Database, tdf As TableDef, fld As DAO.Field
Dim rst As DAO.Recordset, lngCode As Long
Dim strAccessErr As String

Const conAppObjectError = "Application-defined or object-defined error"

On Error GoTo Error_AccessAndJetErrorsTable

' Create Errors table with ErrorNumber and ErrorDescription fields.

Set dbs = CurrentDb
Set tdf = dbs.CreateTableDef("AccessAndJetErrors")
Set fld = tdf.CreateField("ErrorCode", dbLong)

tdf.Fields.Append fld
Set fld = tdf.CreateField("ErrorString", dbMemo)
tdf.Fields.Append fld
dbs.TableDefs.Append tdf

' Open recordset on Errors table.

Set rst = dbs.OpenRecordset("AccessAndJetErrors")

' Loop through error codes.

For lngCode = 0 To 4500

On Error Resume Next

' Raise each error.

strAccessErr = AccessError(lngCode)
DoCmd.Hourglass True

' Skip error numbers without associated strings.

If strAccessErr <> "" Then

' Skip codes that generate application or
' object-defined errors.

If strAccessErr <> conAppObjectError Then
' Add each error code and string to
' Errors table.

rst.AddNew
rst!ErrorCode = lngCode

' Append string to memo field.

rst!ErrorString.AppendChunk strAccessErr
rst.Update

End If
End If

Next lngCode

' Close recordset.

rst.Close
DoCmd.Hourglass False
RefreshDatabaseWindow
MsgBox "Access and Jet errors table created."

AccessAndJetErrorsTable = True

Exit_AccessAndJetErrorsTable:

Exit Function

Error_AccessAndJetErrorsTable:

MsgBox Err & ": " & Err.Description
AccessAndJetErrorsTable = False
Resume Exit_AccessAndJetErrorsTable

End Function