From 53394a8a32e371397f7de4104ba2207ff141d29b Mon Sep 17 00:00:00 2001 From: Hecon5 <54177882+hecon5@users.noreply.github.com> Date: Sat, 23 Sep 2023 09:03:00 -0400 Subject: [PATCH] Updating clsPerformance, as some objects never restart timing, and when resetting some objects are not cleared. Fixes #331 --- .../modules/clsPerformance.cls | 185 +++++++++++++++++- 1 file changed, 179 insertions(+), 6 deletions(-) diff --git a/Version Control.accda.src/modules/clsPerformance.cls b/Version Control.accda.src/modules/clsPerformance.cls index 1621c427..c3ac1779 100644 --- a/Version Control.accda.src/modules/clsPerformance.cls +++ b/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