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
Subscribe to Posts [Atom]