My CallStack Class (Working Demo - Updated code (again))

[cafeenman]

OK, I found a couple more small inconsistencies, a variable that's not being used and added some frivolity for fun. The upload below is good and complete (with the exception of a counter starting at 2 instead of 1 that doesn't really matter). So at some point I will post a final but in the interest of not annoying everyone with continual uploads and fixes I'm going to spend some time actually going through it all one final time and making sure it's as polished as I can make it (without turning it into a full-on app) and will upload again at some point soon.

But what's below works fine as it is. The final version will just be a little bit more refined.

=====================

CallStack Demo3.zip

=====================

OK, I think I'm done working on this demo. I've changed it so that it doesn't create an endless list of files. You can can specify a maximum number of callstack logs as well as number of callstacks per log.

So if you want you can specify a max of 1,000 logs with one call per log or one log with 10000 stacks in it or whatever you want as long as you stay within the limits of a long integer data type and system limitations (maximum file size your OS allows, disk space, memory, etc.).

A little more polishing was done.

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.

=====================

When it's userful:

Normally it isn't. If you're having a problem during development then you use the built-in callstack viewer in the IDE.

It's useful when your app is crashing the IDE or when the compiled app is crashing for reasons unknown.

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.

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 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.


=====================

[xxdoc123]

This one is really good. I have an automated operation software, and often I don't know when a bug will appear. When I debug, there are often no bugs. It sometimes appears in the middle of the night. I've figured out one is a GDI leak

[xxdoc123]

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:

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 Sub

cCallStacker Class:

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 Sub

Usage:

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

It would be nice if there was a complete example.

[cafeenman]

My weekend is about over (I work Fri-Sun overnight) so I'll see what I can whip up but it probably won't be until next week. It's 12-hours shifts with a one-hour commute each way so during my "work week" it's pretty much eat, sleep, go to work, repeat without much time for much else.

Glad you like it though.

[cafeenman]

OK, fine... It took some doing but I got a working demo together.

Link is at the top of the original post.

Let me know what you think.

[cafeenman]

This one is really good. I have an automated operation software, and often I don't know when a bug will appear. When I debug, there are often no bugs. It sometimes appears in the middle of the night. I've figured out one is a GDI leak

If you're automating then you'll probably want to modify the class to not just keep creating files and delete them as you go or just use one file, close it when it reaches the max number of call stacks per file and then reopen for output to clear it out.

If you just let it run as provided you're gonna have a really full disk full of files that you don't need.


In fact, I don't know why I did it this way and I might change it to just keep maybe two or three files max and auto-delete them as I go. That's probably a better approach. The point is to track a bug and I really only need the very last call stack to do that probably.

[cafeenman]

Also too, my coding style and standards have changed a lot over the years and a lot of the stuff included is way, way old so the style has a lot of inconsistency. My app has over 130K lines of code in it and I'm going through it to make it all meet my current standard but this demo is kind of all over the place in that regard. It works but you'll see a lot of "goto cleanup" that I'm getting rid of and a lot of procedures have prefixed variable names such as:

Public Function SumArray(ByVal vArray As Variant) As Double

The way I'm doing things now that would be:

Public Function SumArray(ByVal ArrayOfVariants As Variant) As Double

I'm not super-worried about that for a free demo program because if you choose to use this I'm sure you'll change it all to your own coding style anyway.