VBA ErrorHandler

basErrorHandler.bas

Option Base 0
Option Compare Database
Option Explicit
Option Private Module

'***********************************************************************************************
' ErrorHandler (Public Sub)
'
' PARAMETERS:
'  theForm - String - ByVal - Optional
'  theSub - String - ByVal - Optional
'  addlMsg - String - ByVal - Optional
'
' DEPENDENCIES:
'  LogMsg
'
' DESCRIPTION:
'  Displays a msgbox with the error description. Usage is As follows:
'  If err.number<>0 then ErrorHandler"Form","SubOrFunction","Additional Message"
'  Where Form is the form or module And SubOrFunction is the sub or function name.
'  me.name can be used instead of"Form".
'
' MODIFICATION HISTORY:
' April 2001
'   Daniel J. Pinter
'   General improvements
' June 2000
'   Daniel J. Pinter
'   Initial Version
'***********************************************************************************************
Public Sub ErrorHandler(Optional ByVal theForm As String, Optional ByVal theSub As String, _
                        Optional ByVal addlMsg As String)
  Dim dbError As Error
  Dim saveMouse As Integer
  Dim errDesc As String
  Dim errNumber As String
  Dim errSource As String
  Dim errType As String
  Dim formMsg As String
  Dim moreMsg As String
  Dim msg As String
  Dim sqlText As String
  Dim subMsg As String

'Save the mousepointer (and restore when done).
  saveMouse = Screen.MousePointer
  Screen.MousePointer = MP_DEFAULT

'Pick up the run-time error.
  errDesc = vbNewLine & Err.Description
  errNumber = str$(Err.Number) & " was generated by "
  errSource = Err.Source

'Keep going if any error encontered beyond here.
  On Error Resume Next

  If errSource = Empty Then errSource = "<no source available>"

'Determine error type: Run-time or Database
  If InStr(1, errSource, "DAO") <> 0 _
  Or InStr(1, errSource, "ODBC Teradata Driver") <> 0 _
  Or InStr(1, errSource, "ODBC") <> 0 _
  Or InStr(1, errSource, "Oracle") <> 0 Then
    errType = "Database Error"
  Else
    errType = "Run-Time Error"
  End If

'Build message components based on parameters passed.
  If theSub <> Empty Then subMsg = " in subroutine '" & theSub & "'"
  If theForm <> Empty Then
    If theSub <> Empty Then
      formMsg = " of '" & theForm & "'"
    Else
      formMsg = " in '" & theForm & "'"
    End If
  End If
  If addlMsg <> Empty Then moreMsg = vbNewLine & vbNewLine & addlMsg

  If errType <> "Database Error" Then
'Run-time error
    msg = _
      errType & errNumber & errSource & subMsg & formMsg & ". " & _
      errDesc & _
      moreMsg & _
      sqlText
    LogMsg msg
    MsgBox msg, _
      vbSystemModal + vbCritical + vbOKOnly, _
      strAppName & "-" & errType
  Else
'  Databse error (if any). Because the Errors collection is NEVER cleared out,determine _
  if run-time error due to database issue. _
  NOTE: The lowest level database error is the same As the run-time error.
    For Each dbError In DBEngine.Errors
'  Pick up the database error.
      errDesc = vbNewLine & dbError.Description
      errNumber = str$(dbError.Number) & " was generated by "
      errSource = dbError.Source

'  Build message comPONents.
      If errSource = Empty Then errSource = "<no source available>"
      If sqlstmt <> Empty Then sqlText = vbNewLine & vbNewLine & "SQL: '" & sqlstmt & "'"
'  Database error
      msg = _
        errType & errNumber & errSource & subMsg & formMsg & ". " & _
        errDesc & _
        moreMsg & _
        sqlText
      LogMsg msg
      MsgBox msg, _
        vbSystemModal + vbCritical + vbOKOnly, _
        strAppName & "-" & errType
    Next
  End If

'Clear Err object & restore mouse pointer
  Err.Clear
  Screen.MousePointer = saveMouse
End Sub

'***********************************************************************************************
' LogMsg (Private Sub)
'
' PARAMETERS:
'  strLogMsg - String - ByVal
'
' DESCRIPTION:
'  Sends message to the log file.
'
' MODIFICATION HISTORY:
' April 2001
'   Daniel J. Pinter
'   Initial Version
'***********************************************************************************************
Private Sub LogMsg(ByVal strLogMsg As String)
  On Error Resume Next
  Dim intFile As Integer

  strLogMsg = vbNewLine & _
    Now & " " & LCase(Environ("UserName")) & _
    IIf(InStr(Application.CurrentProject.Name, ".mdb"), " !!DEVELOPMENT!!", vbNullString) & vbNewLine & _
    strLogMsg & vbNewLine & _
    "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
  intFile = FreeFile

  Open strLinkedPath & "\" & _
    Left$(Application.CurrentProject.Name, Len(Application.CurrentProject.Name) - 4) & _
    " Error Log.txt" _
    For Append Shared As intFile
  Print #intFile, strLogMsg
  Close intFile
  DoEvents
End Sub