Option Compare Database
Option Explicit

'Import this code or paste it into a Standard Module.
'This code traps ODBC and VBA Errors, providing detailed information about ODBC errors.
'Reference: http://support.microsoft.com/kb/209855
'---------------------------------------------------------------------------------------
' Procedure : GetErrors
' Author    : Patrick Wood - Gaining Access Technologies - http://gainingaccess.net
' Date      : 9/26/2012, updated 8/14/2013.
' Purpose   : Loop through all DBEngine.Errors and gets all ODBC and VBA Errors.
'           : Most error handling only returns VBA errors. When an ODBC error occurs
'           : multiple error messages are often stored in the DBEngine Errors Collection
'           : but these errors are never seen using common VBA error code. These errors
'           : often contain very specific information about ODBC errors that is very
'           : helpful. This code returns all errors in the DBEngine.Errors Collection.
' Note      : The DBEngine Errors collection is never cleared so there is always at least
'           : one error left in the collection. This procedure raises a specific error
'           : and uses it as a flag so you only see the current ODBC errors.
' Argument  : strProc is the Procedure where the error occurred and can include the Module.
' Usage     : Instead of using something like MsgBox Err.Number & " " & Err.Decription
'           : replace it as shown in the example below.
' Example   : MsgBox GetErrors("MyProcedure of Module MyModule")
'---------------------------------------------------------------------------------------
'

Public Function GetErrors(strProc As StringAs String
'We cannot use "On Error" here or all of the Error Information will be lost.

    Dim dbErr As DAO.Database
    Dim i As Long
    Dim strErr As String
    Dim strDBErr As String
    Dim dteNow As Date
    Dim intLine As Integer
    Dim blnShowAll As Boolean

    'Set blnShowAll to False to get only VBA Error information when VBA and DBEngine Error Number is the same.
    'Set blnShowAll to True to get both VBA and DBEngine information when Error Number is the same.
    blnShowAll = False

    'Get the Errors from the DBEngine Errors Collection.
    With DBEngine.Errors
        For i = 0 To .Count - 1
            'Skip the "dummy" Error.
            If .Item(i).Description <> "Could not find file 'NoDB'." Then
                'If blnShowAll is False get only VBA Error information when the Error Number is the same.
                'If blnShowAll is True and the Error Number is the same get both VBA and DBEngine information.
                If .Item(i).Number <> Err.Number Or blnShowAll = True Then
                    'Build the DBEngine Error String.
                    strDBErr = strDBErr & "DBEngine Error Number: " & .Item(i).Number & vbCrLf
                    strDBErr = strDBErr & "Description: " & .Item(i).Description & vbCrLf
                    strDBErr = strDBErr & "In Procedure " & strProc & vbCrLf
                    'These last three lines are optional - To skip them make them comments.
                    strDBErr = strDBErr & "Error Source: " & .Item(i).Source & vbCrLf
                    'strDBErr = strDBErr & "HelpContext: " & .Item(i).HelpContext & vbCrLf
                    'strDBErr = strDBErr & "HelpFile: " & .Item(i).HelpFile & vbCrLf
                End If
            End If
        Next i
    End With

    'Get the VBA Error information. There is always only one VBA Error.
    strErr = "VBA Error Number: " & Err.Number
    strErr = strErr & vbCrLf & Err.Description
    strErr = strErr & vbCrLf & "In Procedure " & strProc

    'Get the line number where the error occurred if it exits.
    intLine = Nz(Erl, 0)
    If intLine > 0 Then
        strErr = strErr & vbCrLf & "Line Number " & intLine
    End If

    'The next 3 lines of code are optional and can be commented out.
    strErr = strErr & vbCrLf & "Error Source: " & Err.Source
    'strErr = strErr & vbCrLf & "HelpContext: " & Err.HelpContext
    'strErr = strErr & vbCrLf & "HelpFile: " & Err.HelpFile

    'Get the Date and Time of the Error.
    dteNow = Now()
    strErr = strErr & vbCrLf & "Error Date and Time: " & dteNow

    'Add any existing DBEngine Errors to the Error String.
    If Len(strDBErr & "") > 0 Then
        strErr = strDBErr & vbCrLf & strErr
    End If

    'Optional: Uncomment next line of code to save the Error information in a Table.
    'Call SaveErrorInfo(strErr, strProc, dteNow, intLine)

    'The last Error in the DBEngine Errors collection is never removed. If
    'no new DBEngine error has occurred it will still return the last error.
    'So we are creating a "dummy" error that we can check for and skip.
    On Error Resume Next
    Set dbErr = OpenDatabase("NoDB")

    'Return the Error Message
    GetErrors = strErr

End Function




'------------------------------------------------------------------------------------------
' Procedure : SaveErrorInfo
' Author    : Patrick Wood - Gaining Access Technologies http://gainingaccess.net/
' Date      : 3/23/2012, updated 3/25/2013.
' Purpose   : Saves Error Info in tblErrorRecords Table. The design is listed below.
' Note      : If the Table has over 100 records all but the last 50 are deleted.
'           : Save the table in the Front End to get that user's unique errors.
'           : Link to the table in the Back End to get every user's Error records.
' Table     : Below is the Field Names, Data Types, and Sizes in the tblErrorRecords Table.
'------------------------------------------------------------------------------------------
'tblErrorRecords:
'Table Fields       Data Types            Size
'
'ErrorMessageID     Autonumber (Use Long Integer if incrementing ID with code.)
'ErrorMessage       Memo or Long Text
'ErrProcedure       Text or Short Text    255
'ErrorLine          Number                Long Integer
'ErrorDateTime      Date/Time
'ErrorUser          Text or Short Text    50
'ErrorPC            Text or Short Text    50
'------------------------------------------------------------------------------------------
'

Private Function SaveErrorInfo(strErr As String, _
                                strProc As String, _
                                dteNow As Date, _
                                intLine As IntegerAs Boolean
    On Error GoTo ErrHandle

    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Dim strSQL As String    
    Dim strUser As String   'ErrorUser
    Dim strPCName As String 'ErrorComputerName
    Dim lngID As Long       'ErrorMessageID

    'APIs can be used as an alternative to the Environ Function if preferred.
    strUser = Environ("USERNAME")
    strPCName = Environ("COMPUTERNAME")

    'Prepare the SQL to create a recordset to save the error data.
    strSQL = "SELECT * FROM tblErrorRecords"

    'Uncomment the line of code below to increment the ID if you prefer not to use AutoNumber.
    'lngID = Nz(DMax("ErrorMessageID", "tblErrorRecords"), 0) + 1

    Set db = CurrentDb

    'We are using a recordset because sometimes the Error Decription contains
    'delimiters which cause errors resulting in failure to save data in the table.
    Set rst = db.OpenRecordset(strSQL, dbOpenDynaset)

    With rst
        .AddNew
        '!ErrorMessageID = lngID 'Uncomment only if you do not use AutoNumber.
        !ErrorMessage = strErr
        !ErrProcedure = strProc
        !ErrorLine = intLine
        !ErrorDateTime = dteNow
        !ErrorUser = strUser
        !ErrorPC = strPCName
        .Update
    End With

    rst.Close

    'Keep no more than 100 records in the table.
    'Delete the first 50 records if over 100 records exist.
    If DCount("*", "tblErrorRecords") > 100 Then
        lngID = DMax("ErrorMessageID", "tblErrorRecords") - 50

        strSQL = "DELETE * FROM tblErrorRecords" _
            & " WHERE ErrorMessageID < " & lngID & ";"

        db.Execute strSQL, dbFailOnError
    End If

    SaveErrorInfo = True

ExitHere:
    On Error Resume Next
    Set rst = Nothing
    Set db = Nothing
    Exit Function

ErrHandle:
    MsgBox "Error #" & Err.Number & " " & Err.Description _
    & vbCrLf & "In Procedure SaveErrorInfo"
    Resume ExitHere

End Function