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