Global error handler with stack tracing

[dee-u]

This is just a sample of how to use a global error handler that will log application errors together with a stack tracing implementation.

These are the main functions that does the logging.

Public Function PromptAndLogError(ByVal strErrorSource As String, Optional ByVal strOtherInfo As String = vbNullString, Optional ByVal ReplyButton As Long = 2) As Long
    Dim strErrorMessage As String
    Dim strMsg          As String
    Dim strStack        As String
    Dim strErrDesc      As String
    Dim strErrNum       As String
    Dim strErl          As String
    Dim dteErrorOccured As Date
        
    'store the pertinent error values
    strErrDesc = Err.Description
    strErrNum = Err.Number
    strErl = Erl
    
    dteErrorOccured = Now 'get date
    strStack = GetTraces  'get stack trace
    
    strErrorSource = ProgramName & "." & strErrorSource
    
    If Len(strStack) > 0 Then
        strErrorMessage = "Last Trace:        " & strStack & vbCrLf
    End If
    'this will be the logged message, it will contain the stack trace
    strErrorMessage = strErrorMessage & _
                    "Error Occured In:  " & strErrorSource & vbCrLf & _
                    "Error Date & Time: " & dteErrorOccured & vbCrLf & _
                    "Error Description: " & strErrDesc & vbCrLf & _
                    "Error Number:      " & strErrNum & vbCrLf & _
                    "Line Number:       " & strErl
 
    'save other pertinent data that you want to be logged
    If Len(strOtherInfo) > 0 Then
        strErrorMessage = strErrorMessage & (vbCrLf & strOtherInfo)
    End If
    
    'this will be the message to be show to the user
    strMsg = "Error Occured In: " & strErrorSource & vbCrLf & _
             "Error Date & Time: " & dteErrorOccured & vbCrLf & _
             "Error Description: " & strErrDesc & vbCrLf & _
             "Error Number: " & strErrNum & vbCrLf & _
             "Line Number: " & strErl
    
    PromptAndLogError = LogAndProcessError(strMsg, strErrorMessage, dteErrorOccured, True, ReplyButton)
End Function
 
Private Function LogAndProcessError(ByVal MsgBoxError As String, ByVal ErrorMessage As String, ByVal dteErrorOccured As Date, Optional ShowPrompt As Boolean = True, Optional ByVal ReplyButton As Long = 2) As Long
        On Error GoTo HandleError
        
        Dim FileNum         As Integer
        Dim strErrorMessage As String
        Dim Response        As String
        Dim ErrorFile       As String
        Dim PCName          As String
        Dim ScreenFile      As String
        Dim strData         As String
        Dim ProgramPath     As String
        
100     SkipTrace = True
102     ProgramPath = strAppData
        
        'also log error in event viewer
104     App.StartLogging "", vbLogToNT
106     App.LogEvent ErrorMessage, vbLogEventTypeError
    
        'get computer name
108     PCName = GetPCName
 
        'create directory where the error will be logged if the directory does not yet exist
110     If DirectoryExists(ProgramPath & "\ErrorLog\") = False Then
112         CreateFolder ProgramPath & "\ErrorLog\"
        End If
        
        'this will create a unique file for each day
114     ErrorFile = ProgramPath & "\ErrorLog\ErrorLog-" & PCName & "-" & Format$(dteErrorOccured, "mmddyyyy") & ".txt"
116     ScreenFile = ProgramPath & "\ErrorLog\ErrorLog-" & PCName & "-" & Format$(dteErrorOccured, "mmddyyyy-hhnnss") & ".jpg"
        
118     If ShowPrompt = True Then
120         LogAndProcessError = MsgBox(MsgBoxError & vbCrLf & vbCrLf & "Please report to the programmer any persistent error.   ", vbCritical + ReplyButton + vbDefaultButton2, "Unexpected Error Encountered")
            'log also the response of the user
122         Select Case LogAndProcessError
            Case vbAbort
124             Response = "vbAbort"
126         Case vbRetry
128             Response = "vbRetry"
130         Case vbIgnore
132             Response = "vbIgnore"
134         Case vbOK
136             Response = "vbOK"
            End Select
138         If Len(Response) > 0 Then
140             ErrorMessage = ErrorMessage & vbNewLine & "Response:          " & Response
            End If
        End If
    
        'if the log file already exist then append the new error log
142     If FileExists(ErrorFile) = True Then
144         strData = vbCrLf & String$(20, "-") & vbCrLf & ErrorMessage
        Else
146         strData = ErrorMessage
        End If
    
148     FileNum = FreeFile
150     Open ErrorFile For Append As FileNum
152     Print #FileNum, strData
154     Close FileNum
    
        'capture screenshot
156     Capture_Desktop ScreenFile
        
158     Busy False
160     SkipTrace = False
 
        Exit Function
HandleError:
    strErrorMessage = vbNewLine & _
             "Error Occured In:  " & "LogAndProcessError" & vbCrLf & _
             "Error Date & Time: " & dteErrorOccured & vbCrLf & _
             "Error Description: " & Err.Description & vbCrLf & _
             "Error Number:      " & Err.Number & vbCrLf & _
             "Line Number:       " & Erl
    LogMessage strErrorMessage
    Busy False
End Function

And for the stack tracing:

Public Sub PushStack(ByVal strProcedure As String)
    'when in error handling routine then don't register traces
    If SkipTrace = True Then Exit Sub
 
    If ArrayInit(Not colStacks) = False Then
        'initialized
        ReDim Preserve colStacks(0)
        colStacks(0) = strProcedure
    Else
        'increase size
        ReDim Preserve colStacks(UBound(colStacks) + 1)
        colStacks(UBound(colStacks)) = strProcedure
    End If
End Sub
 
Public Sub PopStack()
    If SkipTrace = True Then Exit Sub
 
    If ArrayInit(Not colStacks) = True Then
        If UBound(colStacks) = LBound(colStacks) Then
            Erase colStacks
        Else
            ReDim Preserve colStacks(UBound(colStacks) - 1)
        End If
    End If
End Sub

Sample usage:

Private Sub Command1_Click()
        PushStack "Form1.Command1_Click"
        On Error GoTo HandleError
    
        Dim a As Long
        Dim b As Long
        Dim c As Long
        
100     a = 0
102     b = 1
104     c = b / a 'division by zero
    
ExitProcedure:
        PopStack
        Exit Sub
HandleError:
        Select Case PromptAndLogError("Form1.Command1_Click")
        Case vbAbort
             GoTo ExitProcedure
        Case vbRetry
             Resume
        Case vbIgnore
             Resume Next
        Case Else
             SignalCriticalError Err.Description
             End
        End Select
End Sub

If you happen to use MZTools then this will be the template that you can use:

PushStack "{MODULE_NAME}.{PROCEDURE_NAME}"
   On Error GoTo HandleError

	{PROCEDURE_BODY}

ExitProcedure:
   PopStack
   Exit {PROCEDURE_TYPE}

HandleError:

	Select Case PromptAndLogError("{MODULE_NAME}.{PROCEDURE_NAME}")
        Case vbAbort
             GoTo ExitProcedure
        Case vbRetry
             Resume
        Case vbIgnore
             Resume Next
        Case Else
             SignalCriticalError Err.Description
             End
        End Select

Have a look at the attached project for a complete demo.