Error Handler

Option Compare Binary
Option Explicit

Public Function Handle(ByVal ErrorNumber As Long, _
    ByVal ErrorDescription As String, Optional ByVal Custom As String, _
    Optional ByVal ErrorProcedure As String, _
    Optional ByVal ErrorModule As String)

    On Error GoTo Catch

    Dim ErrorMessage As String, Choice As VBA.VbMsgBoxResult

    If ("Microsoft Access" = Application.Name) Then _
        Application.DoCmd.SetWarnings False

    ErrorMessage = "Error #: " & ErrorNumber _
        & VBA.Constants.vbCrLf _
        & "Error Description: " & ErrorDescription _
        & VBA.Constants.vbCrLf _
        & "Error Module: " & ErrorModule _
        & VBA.Constants.vbCrLf _
        & "Error Procedure: " & ErrorProcedure
    ErrorMessage = IIf(("" = Custom), ErrorMessage, _
        Custom & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf & ErrorMessage)

    If ("Microsoft Access" = Application.Name) Then CreateErrorTable

'   Access>File>Options>Object Designers>Query Design>
'       SQL Server Compatible Syntax (ANSI 92)>This Database
    If ("Microsoft Access" = Application.Name) Then
        Application.DoCmd.RunSQL "INSERT INTO tblError (" _
            & "ErrorNumber, " _
            & "ErrorDescription, " _
            & "ProcedureName, " _
            & "ModuleName, " _
            & "ErrorTimeStamp, " _
            & "UserName, " _
            & "ComputerName" _
            & ") VALUES (" _
            & ErrorNumber & ", " _
            & "'" & VBA.Strings.Replace(ErrorDescription, "'", "''") & "', " _
            & "'" & ErrorProcedure & "', " _
            & "'" & ErrorModule & "', " _
            & "NOW, " _
            & "'" & VBA.Interaction.Environ$("USERNAME") & "', " _
            & "'" & VBA.Interaction.Environ$("COMPUTERNAME") & "')"
    Else
'       Instant alternative. Use another file or sheet logging.
        MsgBox "Error #: " & ErrorNumber _
            & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
            & "Error Description: " & ErrorDescription _
            & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
            & "Error Procedure: " & ErrorProcedure _
            & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
            & "Error Module: " & ErrorModule _
            & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
            & "Timestamp: " & VBA.DateTime.Now _
            & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
            & "Username: " & VBA.Interaction.Environ$("USERNAME") _
            & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
            & "Computername: " & VBA.Interaction.Environ$("COMPUTERNAME"), _
            48, "Error"
    End If

    GoTo Finally

Catch:
    ErrorMessage = "This error will not be logged" _
        & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
        & "Error #: " & VBA.Information.Err.Number _
        & VBA.Constants.vbCrLf _
        & "Error Description: " & VBA.Information.Err.Description _
        & VBA.Constants.vbCrLf _
        & "Error Module: " & Application.VBE.ActiveCodePane.CodeModule.Name _
        & VBA.Constants.vbCrLf _
        & "Error Procedure: Sub Handle"
    Choice = VBA.Interaction.MsgBox(ErrorMessage, 50, "Error handling error")

#If Debugging Then

#End If

    On Error Resume Next

    Select Case Choice

        Case 5
            Resume Next

        Case 4
            Resume

        Case 3
            GoTo Finally

        Case Else

    End Select

Finally:
    If ("Microsoft Access" = Application.Name) Then _
        Application.DoCmd.SetWarnings True

End Function

Private Function ErrorTableExists() As Boolean

    On Error GoTo Catch

    ErrorTableExists = VBA.Conversion.CBool(Application.DCount("[Name]", _
        "MSysObjects", "[Type] = 1 AND [Name] = 'tblError'"))

    GoTo Finally

Catch:
    Handle VBA.Information.Err.Number, VBA.Information.Err.Description, "", _
        "Function ErrorTableExists", _
        Application.VBE.ActiveCodePane.CodeModule.Name

Finally:

End Function

Private Sub CreateErrorTable()

    On Error GoTo Catch

    If ErrorTableExists Then GoTo Finally

    Application.DoCmd.RunSQL "CREATE TABLE tblError (" _
        & "ErrorId AUTOINCREMENT(1, 1) PRIMARY KEY, " _
        & "ErrorNumber INTEGER NOT NULL, " _
        & "ErrorDescription LONGTEXT NOT NULL, " _
        & "ProcedureName VARCHAR NOT NULL, " _
        & "ModuleName VARCHAR NOT NULL, " _
        & "ErrorTimeStamp DATETIME NOT NULL, " _
        & "UserName VARCHAR NOT NULL, " _
        & "ComputerName VARCHAR NOT NULL)"

    GoTo Finally

Catch:
    Handle VBA.Information.Err.Number, VBA.Information.Err.Description, "", _
        "Sub CreateErrorTable", _
        Application.VBE.ActiveCodePane.CodeModule.Name

Finally:

End Sub

Private Sub TruncateErrorTable()

    On Error GoTo Catch

    If Not ErrorTableExists Then GoTo Finally

    Application.DoCmd.Close 0, "tblError", 1
    Application.DoCmd.RunSQL "DELETE FROM tblError", 128
    Application.DoCmd.RunSQL "ALTER TABLE tblError ALTER COLUMN ErrorId " _
        & "COUNTER (1, 1)"

    GoTo Finally

Catch:
    Handle VBA.Information.Err.Number, VBA.Information.Err.Description, "", _
        "Sub TruncateErrorTable", _
        Application.VBE.ActiveCodePane.CodeModule.Name

Finally:

End Sub