2/27/2012

 

VBA Stacktrace

Logging in VBA is hard, believe it or not. There is no obvious way to find out what went wrong even you decided to do some manual logging. Unlike C# or other "industrial" programming environment, there is no easy way to tell the stacktrace of current execution point. The article describes a way that I invented/found to do it "elegantly" (relatively speaking).It looks like
Public Sub GetStockPrice()
If HEG Then On Error GoTo PROC_ERR
  'sub body
PROC_ERR:
  GetLogger().Error "GetStockPrice"
End Sub
Public Sub SetStockCode(StockCode)
If HEG Then On Error GoTo PROC_ERR
    'sub body
PROC_ERR:
    GetLogger().ReraiseError "StockInfoForm.SetStockCode", Array(StockCode)
End Sub
HEG is a global boolean const, stands for "Handle Error Globally". If we wrap all our sub/function with blocks like above, we can ensure there will be logs printed out when some errors happens. And the stacktrace will be available in the log file, along with the invocation parameters in the invocation chain.
You might wonder how it is implemented. Actually quite simple, it is NOT maintaining a stacktrace some where. If we do it that way, we need to push/pop frame into/from the stacktrace. My way is a little bit simpler, it does force you to maintain a separate stacktrace. When a exception is raised, the On Error GoTo statement will catch it, and GetLogger().Error function call will write out the error to log file. One thing is not that obvious is instead of resume next, the GetLogger().ReraiseError function call will also raise another exception, which can be caught in outter level. Again, the reraised exception will be caught and log to file. This way, a stack trace can be recorded in the file, with the root cause in the top, and the most outside calling place in the bottom.
The complete source code is available here (Logger.cls):
Option Explicit

Const Level As String = "Info"
Const Output As String = "File"
Const ReraisedErrorNumber As Long = vbObjectError + 1985

Private Context As New Collection
Private FileNumber As Integer

Public Sub ClearContext()
    Set Context = New Collection
End Sub

Public Sub Error(FunctionName As String, Optional Args)
    If IsMissing(Args) Then
        Args = Array()
    End If
    HandleError False, FunctionName, Args
End Sub

Public Sub ReraiseError(FunctionName As String, Optional Args)
    If IsMissing(Args) Then
        Args = Array()
    End If
    HandleError True, FunctionName, Args
End Sub

Public Sub Info(Msg As String)
    If "Error" = Level Then
        Context.Add Msg
    Else
        PrintToOutput "Info", Msg
    End If
    FlushOutput
End Sub

Public Sub Dbg(Msg As String)
    If "Dbg" = Level Then
        PrintToOutput "Debug", Msg
    Else
        Context.Add Msg
    End If
    FlushOutput
End Sub

Private Sub PrintToOutput(Level As String, Msg As String)
    Dim FormattedMsg As String
    FormattedMsg = "[" + Level + "]" + " " + CStr(Now()) + ": " + Msg
    If "File" = Output Then
        Print #GetFileNumber(), FormattedMsg
    Else
        Debug.Print FormattedMsg
    End If
End Sub

Private Sub FlushOutput()
    Close #GetFileNumber()
    FileNumber = 0
End Sub

Private Function GetFileNumber()
    If FileNumber = 0 Then
        FileNumber = FreeFile
        Open GetFilePath() For Append Access Write Shared As FileNumber
    End If
    GetFileNumber = FileNumber
End Function

Private Function GetFilePath()
Dim FileName As String
    FileName = "zebra-word-" + CStr(Year(Now())) + "-" + CStr(Month(Now())) + "-" + CStr(Day(Now())) + ".log"
    GetFilePath = Application.Path + ":Zebra:Log:" + FileName
End Function

Private Sub HandleError(ReraisesError As Boolean, FunctionName As String, Args)
    If 0 = Err.Number Then
        Exit Sub
    End If
    If ReraisedErrorNumber = Err.Number Then
        PrintToOutput "Error", "Stack: " + FormatInvocation(FunctionName, Args)
    Else
        PrintToOutput "Error", "Stack (Root): " + FormatInvocation(FunctionName, Args)
        PrintToOutput "Error", "Err Number: " + CStr(Err.Number)
        PrintToOutput "Error", "Err Source: " + Err.Source
        PrintToOutput "Error", "Description: " + Err.Description
        PrintToOutput "Error", "Help File: " + Err.HelpFile
        PrintToOutput "Error", "Help Context: " + CStr(Err.HelpContext)
        PrintToOutput "Error", "Last Dll Error: " + CStr(Err.LastDllError)
        DumpContext
    End If
    Err.Clear
    FlushOutput
    If ReraisesError Then
        Err.Raise ReraisedErrorNumber
    Else
        MsgBox "Opps... something wrong happend. Please send your blame to taowen@gmail.com"
    End If
End Sub

Private Sub DumpContext()
Dim Msg
    PrintToOutput "Context", "Dumping context..."
    For Each Msg In Context
        PrintToOutput "Context", CStr(Msg)
    Next Msg
    PrintToOutput "Context", "Dumped context"
    Set Context = New Collection
    FlushOutput
End Sub

Private Function FormatInvocation(FunctionName, Args)
Dim i As Integer
Dim InvocationDescription As String
    InvocationDescription = FunctionName + "("
    For i = LBound(Args) To UBound(Args)
        If i > LBound(Args) Then
            InvocationDescription = InvocationDescription + ", "
        End If
        InvocationDescription = InvocationDescription + FormatArg(Args(i))
    Next i
    InvocationDescription = InvocationDescription + ")"
    FormatInvocation = InvocationDescription
End Function

Private Function FormatArg(Arg)
Dim ArgType As Integer
    ArgType = VarType(Arg)
    If vbEmpty = ArgType Then
        FormatArg = "[Empty]"
    ElseIf vbNull = ArgType Then
        FormatArg = "[Null]"
    ElseIf vbInteger = ArgType Then
        FormatArg = CStr(Arg)
    ElseIf vbLong = ArgType Then
        FormatArg = "[Long]" + CStr(Arg)
    ElseIf vbSingle = ArgType Then
        FormatArg = "[Single]" + CStr(Arg)
    ElseIf vbDouble = ArgType Then
        FormatArg = "[Double]" + CStr(Arg)
    ElseIf vbCurrency = ArgType Then
        FormatArg = "[Currency]" + CStr(Arg)
    ElseIf vbDate = ArgType Then
        FormatArg = "[Date]" + CStr(Arg)
    ElseIf vbString = ArgType Then
        FormatArg = """" + Arg + """"
    ElseIf vbObject = ArgType Then
        FormatArg = "[Object]"
    ElseIf vbError = ArgType Then
        FormatArg = "[Error]"
    ElseIf vbBoolean = ArgType Then
        FormatArg = CStr(Arg)
    ElseIf vbVariant = ArgType Then
        FormatArg = "[Variant]"
    ElseIf vbDataObject = ArgType Then
        FormatArg = "[DataObject]"
    ElseIf vbDecimal = ArgType Then
        FormatArg = "[Decimal]" + CStr(Arg)
    ElseIf vbByte = ArgType Then
        FormatArg = "[Byte]" + CStr(Arg)
    ElseIf vbUserDefinedType = ArgType Then
        FormatArg = "[UserDefinedType]"
    ElseIf vbArray = ArgType Then
        FormatArg = "[Array]"
    Else
        FormatArg = "[Unknown]"
    End If
End Function

Comments: Post a Comment

Subscribe to Post Comments [Atom]





<< Home

This page is powered by Blogger. Isn't yours?

Subscribe to Posts [Atom]