Updating clsPerformance, as some objects never restart timing, and wh…

…en resetting some objects are not cleared. Fixes joyfullservice#331

Version Control.accda.src/modules/clsPerformance.cls

@@ -20,6 +20,7 @@ Attribute VB_Exposed = False
 '           : microsecond level. For additional details, see the following link:
 '           : http://www.mendipdatasystems.co.uk/timer-comparison-tests/4594552971
 '---------------------------------------------------------------------------------------
+
 Option Compare Database
 Option Explicit
 
@@ -76,6 +77,7 @@ End Sub
 Public Property Get CallStack() As String
 
     Dim lngCallStackPosition As Long
+    Dim strCallStackElement As String
 
     If Not Me.Enabled Then Exit Property
 
@@ -96,6 +98,11 @@ Public Property Get CallStack() As String
 End Property
 
 
+Public Property Get CurrentCategoryName() As String
+    CurrentCategoryName = this.CategoryName
+End Property
+
+
 '---------------------------------------------------------------------------------------
 ' Procedure : CategoryStart
 ' Author    : Adam Waller
@@ -105,15 +112,15 @@ End Property
 '
 Public Sub CategoryStart(strName As String)
     If Not Me.Enabled Then Exit Sub
-    If this.CategoryName <> vbNullString Then CategoryEnd
     If this.Categories Is Nothing Then Set this.Categories = New Dictionary
+    If this.CategoryName <> vbNullString Then CategoryEnd
     StartTimer this.Categories, strName
     this.CategoryName = strName
 End Sub
 
 
 '---------------------------------------------------------------------------------------
-' Procedure : ComponentEnd
+' Procedure : CategoryEnd
 ' Author    : Adam Waller
 ' Date      : 11/3/2020
 ' Purpose   : End the timing of the active component
@@ -128,6 +135,11 @@ Public Sub CategoryEnd(Optional lngCount As Long = 1)
 End Sub
 
 
+Public Property Get CurrentOperationName() As String
+    CurrentOperationName = this.OperationName
+End Property
+
+
 '---------------------------------------------------------------------------------------
 ' Procedure : OperationStart
 ' Author    : Adam Waller
@@ -199,6 +211,8 @@ Public Sub OperationEnd(Optional lngCount As Long = 1)
                     this.OperationName = vbNullString
                 End If
             End With
+        Else
+            this.OperationName = vbNullString
         End If
     End If
 
@@ -331,6 +345,9 @@ Public Sub ResumeTiming()
     ' Resume current operation
     If this.OperationName <> vbNullString Then StartTimer this.Operations, this.OperationName
 
+    ' Resume current Category
+    If this.CategoryName <> vbNullString Then StartTimer this.Categories, this.CategoryName
+
 End Sub
 
 
@@ -439,6 +456,9 @@ Public Function GetReports() As String
                 curTotal = curTotal + this.Operations(varKey).Total
             Next varKey
             .Add strSpacer
+            .Add ListResult("TOTALS:", CStr(dblCount), _
+                Format(curTotal, "0." & String$(this.intDigitsAfterDecimal, "0")), lngCol)
+            .Add strSpacer
             If Not this.Overall Is Nothing Then
                 .Add ListResult("Other Operations", vbNullString, _
                     Format(this.Overall.Total - curTotal, "0." & String$(this.intDigitsAfterDecimal, "0")), lngCol)
@@ -479,10 +499,163 @@ End Function
 '           : MyFancyTest      23     2.45
 '---------------------------------------------------------------------------------------
 '
-Private Function ListResult(strHeading As String, strResult1 As String, strResult2 As String, _
-    lngCol() As Long) As String
-    ListResult = PadRight(strHeading, lngCol(0)) & _
-        PadRight(strResult1, lngCol(1)) & strResult2
+Public Function ListResult(ByRef strHeading As String _
+                            , ByRef strResult1 As String _
+                            , ByRef strResult2 As String _
+                            , ByRef lngCol() As Long) As String
+    ListResult = ListResultIndent(strHeading, strResult1, strResult2, lngCol)
+End Function
+
+
+Public Function ListResultIndent(ByRef strHeading As String _
+                                , ByRef strResult1 As String _
+                                , ByRef strResult2 As String _
+                                , ByRef lngCol() As Long _
+                                , Optional ByVal ColumnIndent As Long = 2) As String
+
+    Dim Col1StrArr() As String
+    Dim Col2StrArr() As String
+    Dim Col3StrArr() As String
+
+    Dim Col1Rows As Long
+    Dim Col2Rows As Long
+    Dim Col3Rows As Long
+
+    Dim RowTotal As Long
+    Dim RowPosition As Long
+
+    Dim StrOutput As clsConcat
+
+    On Error Resume Next
+    Perf.OperationStart ModuleName & ".ListResultIndent"
+
+    Col1StrArr = FitStringToColumn(strHeading, lngCol(0) - 1, ColumnIndent)
+    Col2StrArr = FitStringToColumn(strResult1, lngCol(1) - 1, ColumnIndent)
+    Col3StrArr = FitStringToColumn(strResult2, lngCol(2) - 1, ColumnIndent)
+
+    Col1Rows = UBound(Col1StrArr)
+    Col2Rows = UBound(Col2StrArr)
+    Col3Rows = UBound(Col3StrArr)
+
+    RowTotal = MaxValue(Col1Rows, Col2Rows, Col3Rows)
+
+    Set StrOutput = New clsConcat
+
+    For RowPosition = 0 To RowTotal
+
+        If Col1Rows >= RowPosition Then
+            StrOutput.Add PadRight(Col1StrArr(RowPosition), lngCol(0))
+        Else
+            StrOutput.Add Space$(lngCol(0))
+        End If
+        If Col2Rows >= RowPosition Then
+            StrOutput.Add PadRight(Col2StrArr(RowPosition), lngCol(1))
+        Else
+            StrOutput.Add Space$(lngCol(1))
+        End If
+        If Col3Rows >= RowPosition Then
+            StrOutput.Add PadRight(Col3StrArr(RowPosition), lngCol(2))
+        Else
+            StrOutput.Add Space$(lngCol(2))
+        End If
+        ' Don't add a new line for the last line; it's handled outside this tool
+        If RowTotal > RowPosition Then StrOutput.Add vbNewLine
+
+    Next RowPosition
+
+    ListResultIndent = StrOutput.GetStr
+    Perf.OperationEnd
+End Function
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : FitStringToColumn
+' Author    : hecon5
+' Date      : May 18, 2022
+' Purpose   : Takes in a long string and returns an array of strings ColumnWidth wide.
+'---------------------------------------------------------------------------------------
+'
+Public Function FitStringToColumn(ByRef LongString As String _
+                                , Optional ByRef ColumnWidth As Long = 200 _
+                                , Optional ByRef ColumnIndent As Long = 0) As String()
+
+    Dim RowTotal As Long
+    Dim StrLen As Long
+    Dim StrIndentedLen As Long
+    Dim StrTextWidth As Long
+    Dim StrPosition As Long
+    Dim ArrPosition As Long
+    Dim StrArr() As String
+    Dim ColumnWidthInternal As Long
+
+    On Error Resume Next
+    Perf.OperationStart ModuleName & ".FitStringToColumn"
+    If Len(LongString) = 0 Then Exit Function
+    ColumnWidthInternal = ColumnWidth
+    If ColumnWidthInternal <= 0 Then ColumnWidthInternal = 1
+
+    StrTextWidth = ColumnWidthInternal - ColumnIndent
+
+    StrLen = Len(LongString)
+    RowTotal = RoundUp((StrLen - ColumnWidthInternal) / StrTextWidth) + 1
+    If RowTotal < 1 Then RowTotal = 1
+    StrPosition = 1
+
+    ReDim StrArr(0 To (RowTotal - 1))
+
+    ' The first row is longer.
+    StrArr(ArrPosition) = Mid$(LongString, StrPosition, ColumnWidthInternal)
+    If RowTotal <= 1 Then GoTo Exit_Here ' Don't do the rest if there's only one row...
+
+    StrPosition = StrPosition + ColumnWidthInternal
+
+    For ArrPosition = 1 To (RowTotal - 1)
+        StrArr(ArrPosition) = Space$(ColumnIndent) & Mid$(LongString, StrPosition, StrTextWidth)
+        StrPosition = StrPosition + StrTextWidth
+    Next ArrPosition
+
+Exit_Here:
+    CatchAny eelError, "Could not fit to column", Perf.CurrentOperationName
+    FitStringToColumn = StrArr
+    Perf.OperationEnd
+End Function
+
+
+Public Function FitStringToWidth(ByRef LongString As String _
+                                , Optional ByRef MaxWidth As Long = 200 _
+                                , Optional ByRef DesiredWidth As Long = 75) As String
+    ' Fits a string to a message box if it's wider than MaxWidth
+    Dim OutputConcat As clsConcat
+    Dim StrPosition As Long
+    Dim StrLen As Long ' Length of total string
+    Dim NewLineCount As Long ' Number of newlines
+    Dim ArrPosition As Long
+    Dim StrArrLen As Long ' Length of substring
+    Dim StringArr() As String
+
+    Perf.OperationStart "FitStringToWidth"
+    StrLen = Len(LongString)
+    If StrLen > MaxWidth Then
+        Perf.OperationStart "FitStringToWidth.Resize"
+        StringArr = Split(LongString, vbNewLine, , vbTextCompare)
+        NewLineCount = UBound(StringArr) - LBound(StringArr)
+        Set OutputConcat = New clsConcat
+        For ArrPosition = 0 To NewLineCount
+            StrPosition = 1
+            StrArrLen = Len(StringArr(ArrPosition))
+            If ArrPosition > 0 Then OutputConcat.Add vbNewLine
+            Do While StrPosition < StrArrLen
+                If StrPosition > 1 Then OutputConcat.Add vbNewLine
+                OutputConcat.Add Mid$(StringArr(ArrPosition), StrPosition, DesiredWidth)
+                StrPosition = StrPosition + DesiredWidth
+            Loop
+        Next ArrPosition
+        FitStringToWidth = OutputConcat.GetStr
+        Perf.OperationEnd
+    Else
+        FitStringToWidth = LongString
+    End If
+    Perf.OperationEnd
 End Function