CallStack Demo.zip
If you have MZTools or something like it you can create a macro that automatically inserts the callstack stuff into any procedure with the correct information.
I really like MZTools.
I forgot to add a dot in there. Still works but has one weird entry.
in chkLogCallsToFile_Click change the following:
change this: m_CallStacker.Add Me.NAME & "chkLogCallsToFile_Click(Private Sub)"
To this: m_CallStacker.Add Me.NAME & ".chkLogCallsToFile_Click(Private Sub)"
Just needs the dot first thing after the first quote.
Also left out the dot in the Form_Unload Sub.
Also left out the dot in Text1_Change
=====================
How It works:
I don't remember.
What it does:
It counts every call to every procedure that adds to the call stack. When the program exits (only if it's enabled at exit) it provides a list of every procedure called, how many times it was called and the deepest call stack.
Every single call is logged to file. The file is opened and when the max number of entries (specified in the cCallStack Initialize Sub) is reached it closes the file and opens a new one.
So if you look at one of the callstack files you see that the stack increases one call at a time and then backs out one call at a time until the stack has nothing left on it. (Edit: I just looked a callstack file and it doesn't look like I added logging when it backs out. I'll have to check it again.)
When the program exits on purpose the current active callstack file is closed.
if the program crashes when a file is open then we count on Windows to close the file and hopefully you'll be able to look at the last callstack in the last file and see the stack that led up to the crash.
In my real app, all the totals are put into an application log file. In the demo it's put into the immediate window.
If you do too much with the demo then all the stats will be scrolled off the top of the immediate window so you just want to type a little bit, click a few things and then exit.
You could also just write that to the Windows Clipboard instead and then paste it into a text document instead.
You will find that in the CloseLogFile Function in the ErrorHandler bas module.
Where this really shines is that if you're in the IDE and something is going on and you set a breakpoint AND you have some kind of API thing going on, such as changing the color of a toolbar or SSTab or whatever, the program might crash and bring down the entire IDE even if the API call wasn't the problem.
This allows you to keep running and figure out what's going on without hitting CTRL+ Break to pause program execution which can sometimes kill everything for reasons other than whatever actual problem you're trying to sort out.
I'd appreciate any feedback you can give me.
On now to the original post...
=====================
OK... that was click-bait. It's not a mess but man does it bring my app to its knees. For example, when I click the Communications Button (which saves whatever setting it had last such as ALL, Past Week, Past Two Weeks, This Quarter, etc.) and it's set to ALL then I can go get lunch and come back and it might be finished.
The problem is that if I wait to log stuff for whatever time-period and the app crashes or has some weird hard-to-track bug, then the callstack class is worthless if it doesn't save the current call stack.
So writing that to file is REALLY slow but it's the only way I know to make sure I have the information I need if something happens.
I only turn it on when I find a bug that I can't track using more conventional means.
I mean it's really bad. But I don't have a better answer.
And if you do and it means me having to rewrite all my code (there are over 8,000 procedures making calls to the callstack in this app) then I'll love/hate you for doing that to me. :)
This is the whole class:
cCallStacker Class:
Usage:
If you have MZTools or something like it you can create a macro that automatically inserts the callstack stuff into any procedure with the correct information.
I really like MZTools.
I forgot to add a dot in there. Still works but has one weird entry.
in chkLogCallsToFile_Click change the following:
change this: m_CallStacker.Add Me.NAME & "chkLogCallsToFile_Click(Private Sub)"
To this: m_CallStacker.Add Me.NAME & ".chkLogCallsToFile_Click(Private Sub)"
Just needs the dot first thing after the first quote.
Also left out the dot in the Form_Unload Sub.
Also left out the dot in Text1_Change
=====================
How It works:
I don't remember.
What it does:
It counts every call to every procedure that adds to the call stack. When the program exits (only if it's enabled at exit) it provides a list of every procedure called, how many times it was called and the deepest call stack.
Every single call is logged to file. The file is opened and when the max number of entries (specified in the cCallStack Initialize Sub) is reached it closes the file and opens a new one.
So if you look at one of the callstack files you see that the stack increases one call at a time and then backs out one call at a time until the stack has nothing left on it. (Edit: I just looked a callstack file and it doesn't look like I added logging when it backs out. I'll have to check it again.)
When the program exits on purpose the current active callstack file is closed.
if the program crashes when a file is open then we count on Windows to close the file and hopefully you'll be able to look at the last callstack in the last file and see the stack that led up to the crash.
In my real app, all the totals are put into an application log file. In the demo it's put into the immediate window.
If you do too much with the demo then all the stats will be scrolled off the top of the immediate window so you just want to type a little bit, click a few things and then exit.
You could also just write that to the Windows Clipboard instead and then paste it into a text document instead.
You will find that in the CloseLogFile Function in the ErrorHandler bas module.
Where this really shines is that if you're in the IDE and something is going on and you set a breakpoint AND you have some kind of API thing going on, such as changing the color of a toolbar or SSTab or whatever, the program might crash and bring down the entire IDE even if the API call wasn't the problem.
This allows you to keep running and figure out what's going on without hitting CTRL+ Break to pause program execution which can sometimes kill everything for reasons other than whatever actual problem you're trying to sort out.
I'd appreciate any feedback you can give me.
On now to the original post...
=====================
OK... that was click-bait. It's not a mess but man does it bring my app to its knees. For example, when I click the Communications Button (which saves whatever setting it had last such as ALL, Past Week, Past Two Weeks, This Quarter, etc.) and it's set to ALL then I can go get lunch and come back and it might be finished.
The problem is that if I wait to log stuff for whatever time-period and the app crashes or has some weird hard-to-track bug, then the callstack class is worthless if it doesn't save the current call stack.
So writing that to file is REALLY slow but it's the only way I know to make sure I have the information I need if something happens.
I only turn it on when I find a bug that I can't track using more conventional means.
I mean it's really bad. But I don't have a better answer.
And if you do and it means me having to rewrite all my code (there are over 8,000 procedures making calls to the callstack in this app) then I'll love/hate you for doing that to me. :)
This is the whole class:
Code:
Option Explicit
' // Constants, Types and Enums.
Public Enum CALL_STACK_ARRANGMENT
idx_CallStackArrangment_CallDate = 0
idx_CallStackArrangment_DateCall
idx_CallStackArrangment_CallOnly
idx_CallStackArrangment_DateOnly
End Enum
Public Enum LOG_PROCEDURE_CALLS
idx_LogProcedureCalls_No = 0
idx_LogProcedureCalls_Yes = 1
End Enum
' / Constants, Types and Enums.
' // Objects
' / Controls.
Private WithEvents mw_ArrangementComboBox As ComboBox
' / Controls.
' / Objects
' // Properties.
Private nArrangement As Long
Private sCalledProcedures() As String
Private nCalledProceduresCount() As Long
Private sCallID As String
Private sCallLog As String
Private iCallLogFileNum As Integer
Private rCallNumber As Double
Private sCallStack() As String
Private nCallStacksPerFile As Long
Private rCallStackTime() As Double
Private sDeepestCallStack() As String
Private rDeepestCallStackTime() As Double
Private nLogCalls As Long
Private sLogFolder As String
Private nMaxCallStackLog As Long
' / Properties.
Public Property Get ActiveCallStack() As String
Dim s As String
On Error GoTo errHandler
ActiveCallStack = vbNullString
If Not ArrayInitialized(sCallStack) Then GoTo CleanUp
s = "Call Stack:" & DBL_RETURN
s = s & CallText(sCallStack, rCallStackTime)
ActiveCallStack = s
CleanUp:
Exit Property
errHandler:
Dim nErrorHandlerResult As Long
nErrorHandlerResult = ErrorHandler(Error, Err, vbNullString, Me.NAME & ".ActiveCallStack(Public Property Get)")
Resume CleanUp
End Property
Public Property Get ActiveStackCount() As Long
On Error GoTo errHandler
ActiveStackCount = UBound(sCallStack) + 1
Exit Property
errHandler:
ActiveStackCount = 0
End Property
Public Function Add(ByVal ModuleAndProcedureName As String) As Long
Dim nResult As Long
Dim nErr As Long
' Returns Error Code.
On Error GoTo errHandler
nErr = 0
If ErrorHandler.TERMINAL_ERROR Then Exit Function
CallID = NextCallID
If DebugMode = idx_Debug_Off Then Exit Function
nResult = AppendCallStackString(ModuleAndProcedureName)
If nResult <> 0 Then Err.Raise nResult
nResult = IncrementProcedureCallCount(ModuleAndProcedureName)
If nResult <> 0 Then Err.Raise nResult
LogCallStack
CleanUp:
Add = nErr
Exit Function
errHandler:
nErr = Err
Resume CleanUp
End Function
Private Function AppendCallStackString(ByVal ModuleAndProcedureName As String) As Long
Dim nErr As Long
Dim n As Long
Static nMax As Long
' Returns Error Code.
On Error GoTo errHandler
nErr = 0
If ArrayInitialized(sCallStack) Then
n = UBound(sCallStack) + 1
ReDim Preserve sCallStack(n)
ReDim Preserve rCallStackTime(n)
Else
n = 0
ReDim sCallStack(n)
ReDim rCallStackTime(n)
End If
sCallStack(n) = ModuleAndProcedureName
rCallStackTime(n) = Timer
If n > nMax Then
nMax = n
sDeepestCallStack = sCallStack
rDeepestCallStackTime = rCallStackTime
End If
CleanUp:
AppendCallStackString = nErr
Exit Function
errHandler:
n = 0
Resume Next
End Function
Public Property Get Arrangement() As CALL_STACK_ARRANGMENT
Arrangement = nArrangement
End Property
Public Property Let Arrangement(ByVal CallArrangement As CALL_STACK_ARRANGMENT)
nArrangement = CallArrangement
End Property
Public Property Set ArrangmentComboBox(ByRef ctlComboBox As ComboBox)
Set mw_ArrangementComboBox = ctlComboBox
PopulateList
End Property
Private Function ArrIndex(ByRef ArrayOfStrings() As String, ByRef vItem As Variant) As Long
Dim nResult As Long
Dim n As Long
' Returns Index if Item is found.
' Returns FAILED (-1) if not found.
' Strings are not case-sensitive.
On Error GoTo errHandler
nResult = FAILED
If Not ArrayInitialized(ArrayOfStrings) Then GoTo CleanUp
For n = LBound(ArrayOfStrings) To UBound(ArrayOfStrings)
If ArrayOfStrings(n) = vItem Then
nResult = n
GoTo CleanUp
End If
Next n
CleanUp:
ArrIndex = nResult
Exit Function
errHandler:
Dim nErrorHandlerResult As Long
Dim sError As String
Dim nErr As Long
Dim Parameters(2) As String
sError = Error
nErr = Err
Parameters(0) = ParameterArray_str(ArrayOfStrings, "ArrayOfStrings")
Parameters(1) = "vItem = " & vItem
Parameters(2) = "n = " & CStr(n)
nErrorHandlerResult = ErrorHandler(sError, nErr, ParameterString(Parameters), Me.NAME & ".ArrIndex(Public Function)")
Resume CleanUp
End Function
Private Function ArrayInitialized(ByRef ArrayOfStrings() As String) As Boolean
On Error GoTo errHandler
ArrayInitialized = False
If SafeArrayGetDim(ArrayOfStrings) <> 0 Then ArrayInitialized = True
Exit Function
errHandler:
ArrayInitialized = False
End Function
Public Property Get CalledProcedures() As String()
CalledProcedures = sCalledProcedures
End Property
Public Property Get CalledProceduresCount() As Long
' Returns number of Distinct Procedures that have been called.
CalledProceduresCount = ArrayUbound(nCalledProceduresCount) + 1
End Property
Public Property Get CalledProceduresCounts() As Long()
' Returns Array containing number of times each procedure was called.
CalledProceduresCounts = nCalledProceduresCount
End Property
Public Property Get CallStacksPerFile() As Long
CallStacksPerFile = nCallStacksPerFile
End Property
Public Property Let CallStacksPerFile(ByVal CallsPerFile As Long)
nCallStacksPerFile = CallsPerFile
End Property
Private Property Get CallText(ByRef Calls() As String, ByRef Times() As Double) As String
Dim sCall As String
Dim sTime As String
Dim s As String
Dim n As Long
For n = LBound(Calls) To UBound(Calls)
sCall = Calls(n)
sTime = Format(Times(n), "0.000")
Select Case Arrangement
Case idx_CallStackArrangment_CallDate
s = s & sCall & vbTab & sTime
Case idx_CallStackArrangment_DateCall
s = s & sTime & vbTab & sCall
Case idx_CallStackArrangment_CallOnly
s = s & sCall & vbCrLf
Case idx_CallStackArrangment_DateOnly
s = s & sTime
End Select
Next n
CallText = s & vbCrLf
End Property
Private Property Get CallID() As String
CallID = sCallID
End Property
Private Property Let CallID(ByVal ProcedureCallID As String)
sCallID = ProcedureCallID
End Property
Public Property Get CallLog() As String
CallLog = sCallLog
End Property
Private Property Let CallLog(ByVal FileSpec As String)
sCallLog = FileSpec
End Property
Public Property Get DeepestCallStack() As String
Dim s As String
On Error GoTo errHandler
DeepestCallStack = vbNullString
If Not ArrayInitialized(sDeepestCallStack) Then Exit Property
s = "Deepest Call Stack (" & UBound(sDeepestCallStack) + 1 & ")" & DBL_RETURN
s = s & CallText(sDeepestCallStack, rDeepestCallStackTime)
DeepestCallStack = s
Exit Property
errHandler:
Dim nErrorHandlerResult As Long
nErrorHandlerResult = ErrorHandler(Error, Err, vbNullString, Me.NAME & ".DeepestCallStack(Public Property Get)")
End Property
Public Function DeleteProcedureCall() As Long
Dim nErr As Long
Dim n As Long
' Returns Error Code.
On Error GoTo errHandler
nErr = 0
If DebugMode = idx_Debug_Off Then Exit Function
If ArrayInitialized(sCallStack) Then
n = UBound(sCallStack)
Else
n = 0
End If
n = n - 1
If n < 0 Then
Erase sCallStack
Else
ReDim Preserve sCallStack(n)
End If
CleanUp:
DeleteProcedureCall = nErr
Exit Function
errHandler:
nErr = Err
Resume Next
End Function
Public Function DestroyObjects() As Long
Set mw_ArrangementComboBox = Nothing
On Error Resume Next
Close iCallLogFileNum
End Function
Private Function IncrementProcedureCallCount(ByVal Item As String) As Long
Dim nIndex As Long
Dim nBound As Long
On Error GoTo errHandler
If DebugMode = idx_Debug_Off Then Exit Function
nIndex = ArrIndex(CalledProcedures, Item) ' Search CallStack to see if it contains Procedure (Item).
If nIndex >= 0 Then ' Procedure was found so increment number of times it has been called.
nCalledProceduresCount(nIndex) = nCalledProceduresCount(nIndex) + 1
Exit Function
End If
If ArrayInitialized(sCalledProcedures) Then
nBound = UBound(sCalledProcedures) + 1 ' Procedure wasn't found so add it to CalledProcedures Array.
Else
nBound = 0
End If
ReDim Preserve sCalledProcedures(nBound)
sCalledProcedures(nBound) = Item
ReDim Preserve nCalledProceduresCount(nBound)
nCalledProceduresCount(nBound) = 1
Exit Function
errHandler:
nBound = 0
Resume Next
End Function
Public Property Get LogCalls() As Long
LogCalls = nLogCalls
End Property
Public Property Let LogCalls(ByVal LogAllCalls As Long)
nLogCalls = LogAllCalls
End Property
Private Function LogCallStack() As Long
Dim nErr As Long
Dim s As String
Static rTotal As Double
' Returns Error Code.
On Error GoTo errHandler
If ErrorHandler.TERMINAL_ERROR Then Exit Function
If LogProcedureCallStack = vbUnchecked Then Exit Function
If rTotal = 0 Then rTotal = 1
If (rTotal Mod CallStacksPerFile = 0) Or iCallLogFileNum = 0 Then
StartCallStackLog
End If
s = CallID & vbCrLf & Join(sCallStack, vbCrLf)
Print #iCallLogFileNum, vbNullString
Print #iCallLogFileNum, s
CleanUp:
LogCallStack = nErr
rTotal = rTotal + 1
Exit Function
errHandler:
nErr = Err
Resume CleanUp
End Function
Private Property Get LogFolder() As String
LogFolder = sLogFolder
End Property
Private Property Let LogFolder(ByVal FolderSpec As String)
sLogFolder = FolderSpec
End Property
Public Property Get LogProcedureCalls(ByVal ObjectName As String) As DEBUG_MODE
Dim RST As DAO.Recordset
Dim SQL As String
Dim nRecordcount As Long
SQL = "SELECT * FROM ObjectLogging WHERE ObjectName=" & AddSingleQuotes(ObjectName)
nRecordcount = OpenRST(RST, SQL, idx_Recordset_Dynaset)
With RST
If nRecordcount = 0 Then
.AddNew
.Fields("ObjectName") = ObjectName
.Fields("LogProcedureCalls") = 1
.Update
LogProcedureCalls = idx_Debug_On
Else
LogProcedureCalls = .Fields("LogProcedureCalls")
End If
End With
RecordsetClose RST
End Property
Public Property Let LogProcedureCalls(ByVal ObjectName As String, DebugMode As DEBUG_MODE)
Dim RST As DAO.Recordset
Dim SQL As String
Dim nRecordcount As Long
SQL = "SELECT * FROM ObjectLogging WHERE ObjectName=" & AddSingleQuotes(ObjectName)
nRecordcount = OpenRST(RST, SQL, idx_Recordset_Dynaset)
With RST
If nRecordcount = 0 Then
.AddNew
.Fields("ObjectName") = ObjectName
Else
.Edit
End If
.Fields("LogProcedureCalls") = DebugMode
.Update
End With
RecordsetClose RST
End Property
Public Property Get MaxCallStackLog() As Long
MaxCallStackLog = nMaxCallStackLog
End Property
Public Property Let MaxCallStackLog(ByVal MaxStacksLogged As Long)
nMaxCallStackLog = MaxStacksLogged
End Property
Public Property Get NAME() As String
NAME = "cCallStack"
End Property
Private Property Get NextCallID() As String
rCallNumber = rCallNumber + 1
NextCallID = AirfieldApp.SessionID & CHAR_SPACE & rCallNumber
End Property
Private Function PopulateList() As Long
Dim nErr As Long
' Returns Error Code.
On Error GoTo errHandler
nErr = 0
If mw_ArrangementComboBox Is Nothing Then GoTo CleanUp
With mw_ArrangementComboBox
.Clear
.AddItem "Procedure Call - Date"
.Itemdata(.NewIndex) = idx_CallStackArrangment_CallDate
.AddItem "Date - Procedure Call"
.Itemdata(.NewIndex) = idx_CallStackArrangment_DateCall
.AddItem "Procedure Call Only"
.Itemdata(.NewIndex) = idx_CallStackArrangment_CallOnly
.AddItem "Date Only"
.Itemdata(.NewIndex) = idx_CallStackArrangment_DateOnly
End With
ListIndexFromItemData mw_ArrangementComboBox, Arrangement
CleanUp:
PopulateList = nErr
Exit Function
errHandler:
Dim nErrorHandlerResult As Long
nErr = Err
nErrorHandlerResult = ErrorHandler(Error, nErr, vbNullString, Me.NAME & ".PopulateList(Private Function)")
Resume CleanUp
End Function
Private Function StartCallStackLog() As Long
Dim nErr As Long
' Returns Error Code.
On Error GoTo errHandler
nErr = 0
Close #iCallLogFileNum
If DebugMode = idx_Debug_Off Then GoTo CleanUp
CallLog = LogFolder & "Call Stacks " & AirfieldApp.SessionID & CHAR_SPACE & DateTimeSerial & ".txt"
iCallLogFileNum = FreeFile
Open CallLog For Output As #iCallLogFileNum
CleanUp:
StartCallStackLog = nErr
Exit Function
errHandler:
Dim nErrorHandlerResult As Long
nErr = Err
nErrorHandlerResult = ErrorHandler(Error, nErr, vbNullString, Me.NAME & ".StartCallStackLog(Private Function)")
Resume CleanUp
End Function
Public Property Get TotalCalledProceduresCount() As Long
TotalCalledProceduresCount = SumArray(nCalledProceduresCount)
End Property
Public Function TotalCalls() As String
Dim s As String
Dim n As Long
Dim rCount As Double
On Error GoTo errHandler
If ArrayInitialized(CalledProcedures) Then
s = "Procedure Call Counts: " & DBL_RETURN
For n = LBound(CalledProcedures) To UBound(CalledProcedures)
s = s & Format(nCalledProceduresCount(n), "000000000") & vbTab & sCalledProcedures(n) & vbCrLf
rCount = rCount + nCalledProceduresCount(n)
Next n
s = s & vbCrLf & vbTab & "Procedures Called: " & UBound(CalledProcedures) + 1 & vbCrLf
Else
s = "Procedure Call Counts: " & vbCrLf
s = s & vbCrLf & vbTab & "Procedures Called: Logging not Active." & vbCrLf
End If
If rCount Then
s = s & vbCrLf & vbTab & "Total Procedure Calls: " & rCount & DBL_RETURN
Else
s = s & vbCrLf & vbTab & "Total Procedure Calls: Logging not Active."
End If
s = s & DeepestCallStack
TotalCalls = s
Exit Function
errHandler:
Dim nErrorHandlerResult As Long
nErrorHandlerResult = ErrorHandler(Error, Err, vbNullString, Me.NAME & ".TotalCalls(Public Function)")
End Function
Private Sub mw_ArrangementComboBox_Change()
mw_ArrangementComboBox_Click
End Sub
Private Sub mw_ArrangementComboBox_Click()
Arrangement = Itemdata(mw_ArrangementComboBox)
End Sub
Private Sub Class_Initialize()
Arrangement = idx_CallStackArrangment_DateCall
LogFolder = AirfieldApp.LogFolder
CallStacksPerFile = 10000
StartCallStackLog
End SubCode:
Option Explicit
' Eliminates need for each Procedure to call DeleteProcedureCall.
' DeleteProcedureCall is called automatically when instance of this class goes out of scope.
' // Constants, Types and Enums.
Private Const NAME As String = "cCallStacker"
' / Constants, Types and Enums.
Public Sub Add(ByRef ProcedureInfo As String)
If DebugMode = idx_Debug_Off Then Exit Sub
CallStack.Add ProcedureInfo
End Sub
Private Sub Class_Terminate()
If DebugMode = idx_Debug_Off Then Exit Sub
CallStack.DeleteProcedureCall
End SubUsage:
Code:
Private Sub SomeSub()
dim m_CallStacker As New cCallStacker
m_CallStacker.Add (name of module) & ".SomeSub(Private Sub)"
If This Then
DoThat
Else
DontDoItImNotTheBossOfYou
End If
End Sub