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 1/6] 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 From 4a27077e2d2843d901fe9860d795df32912bb4a6 Mon Sep 17 00:00:00 2001 From: Hecon5 <54177882+hecon5@users.noreply.github.com> Date: Sat, 23 Sep 2023 09:19:57 -0400 Subject: [PATCH 2/6] Fixing Private/Public declarations. --- .../modules/clsPerformance.cls | 84 +++++++++++++------ 1 file changed, 60 insertions(+), 24 deletions(-) diff --git a/Version Control.accda.src/modules/clsPerformance.cls b/Version Control.accda.src/modules/clsPerformance.cls index c3ac1779..3f345019 100644 --- a/Version Control.accda.src/modules/clsPerformance.cls +++ b/Version Control.accda.src/modules/clsPerformance.cls @@ -499,7 +499,7 @@ End Function ' : MyFancyTest 23 2.45 '--------------------------------------------------------------------------------------- ' -Public Function ListResult(ByRef strHeading As String _ +Private Function ListResult(ByRef strHeading As String _ , ByRef strResult1 As String _ , ByRef strResult2 As String _ , ByRef lngCol() As Long) As String @@ -507,7 +507,7 @@ Public Function ListResult(ByRef strHeading As String _ End Function -Public Function ListResultIndent(ByRef strHeading As String _ +Private Function ListResultIndent(ByRef strHeading As String _ , ByRef strResult1 As String _ , ByRef strResult2 As String _ , ByRef lngCol() As Long _ @@ -524,10 +524,9 @@ Public Function ListResultIndent(ByRef strHeading As String _ Dim RowTotal As Long Dim RowPosition As Long - Dim StrOutput As clsConcat + 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) @@ -539,32 +538,74 @@ Public Function ListResultIndent(ByRef strHeading As String _ RowTotal = MaxValue(Col1Rows, Col2Rows, Col3Rows) - Set StrOutput = New clsConcat + Set strOutput = New clsConcat For RowPosition = 0 To RowTotal If Col1Rows >= RowPosition Then - StrOutput.Add PadRight(Col1StrArr(RowPosition), lngCol(0)) + strOutput.Add PadRight(Col1StrArr(RowPosition), lngCol(0)) Else - StrOutput.Add Space$(lngCol(0)) + strOutput.Add Space$(lngCol(0)) End If If Col2Rows >= RowPosition Then - StrOutput.Add PadRight(Col2StrArr(RowPosition), lngCol(1)) + strOutput.Add PadRight(Col2StrArr(RowPosition), lngCol(1)) Else - StrOutput.Add Space$(lngCol(1)) + strOutput.Add Space$(lngCol(1)) End If If Col3Rows >= RowPosition Then - StrOutput.Add PadRight(Col3StrArr(RowPosition), lngCol(2)) + strOutput.Add PadRight(Col3StrArr(RowPosition), lngCol(2)) Else - StrOutput.Add Space$(lngCol(2)) + 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 + If RowTotal > RowPosition Then strOutput.Add vbNewLine Next RowPosition - ListResultIndent = StrOutput.GetStr - Perf.OperationEnd + ListResultIndent = strOutput.GetStr +End Function + + +Private Function MaxValue(ParamArray ValueIn() As Variant) As Variant + Dim Output As Variant + Dim ArrayPosition As Long + + ' Load the first value in to compare to. + Output = ValueIn(LBound(ValueIn)) + + For ArrayPosition = LBound(ValueIn) + 1 To UBound(ValueIn) + If Output < ValueIn(ArrayPosition) Then Output = ValueIn(ArrayPosition) + Next ArrayPosition + + MaxValue = Output +End Function + + +Private Function RoundUp(ByVal Value As Double) As Long + Dim lngVal As Long + Dim deltaValue As Double + + lngVal = CLng(Value) + deltaValue = lngVal - Value + + If deltaValue < 0 Then + RoundUp = lngVal + 1 + Else + RoundUp = lngVal + End If +End Function +Private Function RoundDown(ByVal Value As Double) As Long + Dim lngVal As Long + Dim deltaValue As Double + + lngVal = CLng(Value) + deltaValue = lngVal - Value + + If deltaValue <= 0 Then + RoundDown = lngVal + Else + RoundDown = lngVal - 1 + End If End Function @@ -575,7 +616,7 @@ End Function ' Purpose : Takes in a long string and returns an array of strings ColumnWidth wide. '--------------------------------------------------------------------------------------- ' -Public Function FitStringToColumn(ByRef LongString As String _ +Private Function FitStringToColumn(ByRef LongString As String _ , Optional ByRef ColumnWidth As Long = 200 _ , Optional ByRef ColumnIndent As Long = 0) As String() @@ -589,7 +630,6 @@ Public Function FitStringToColumn(ByRef LongString 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 @@ -615,13 +655,11 @@ Public Function FitStringToColumn(ByRef LongString As String _ 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 _ +Private 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 @@ -633,10 +671,8 @@ Public Function FitStringToWidth(ByRef LongString As String _ 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 @@ -651,11 +687,9 @@ Public Function FitStringToWidth(ByRef LongString As String _ Loop Next ArrPosition FitStringToWidth = OutputConcat.GetStr - Perf.OperationEnd Else FitStringToWidth = LongString End If - Perf.OperationEnd End Function @@ -666,7 +700,9 @@ End Function ' Purpose : Pads a string '--------------------------------------------------------------------------------------- ' -Private Function PadRight(strText As String, lngLen As Long, Optional lngMinTrailingSpaces As Long = 1) As String +Private Function PadRight(strText As String _ + , lngLen As Long _ + , Optional lngMinTrailingSpaces As Long = 1) As String Dim strResult As String Dim strTrimmed As String From bd2453851852ee993118b01788c549021bf09f7f Mon Sep 17 00:00:00 2001 From: Hecon5 <54177882+hecon5@users.noreply.github.com> Date: Sat, 23 Sep 2023 09:21:13 -0400 Subject: [PATCH 3/6] This isn't actually used. --- Version Control.accda.src/modules/clsPerformance.cls | 1 - 1 file changed, 1 deletion(-) diff --git a/Version Control.accda.src/modules/clsPerformance.cls b/Version Control.accda.src/modules/clsPerformance.cls index 3f345019..7ef5bc1f 100644 --- a/Version Control.accda.src/modules/clsPerformance.cls +++ b/Version Control.accda.src/modules/clsPerformance.cls @@ -77,7 +77,6 @@ End Sub Public Property Get CallStack() As String Dim lngCallStackPosition As Long - Dim strCallStackElement As String If Not Me.Enabled Then Exit Property From 6e8007a4fe57d34df86aba93441573c2037c3646 Mon Sep 17 00:00:00 2001 From: Hecon5 <54177882+hecon5@users.noreply.github.com> Date: Sat, 23 Sep 2023 09:26:30 -0400 Subject: [PATCH 4/6] Bump Version --- Version Control.accda.src/dbs-properties.json | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Version Control.accda.src/dbs-properties.json b/Version Control.accda.src/dbs-properties.json index 9c197f0f..0f394126 100644 --- a/Version Control.accda.src/dbs-properties.json +++ b/Version Control.accda.src/dbs-properties.json @@ -41,7 +41,7 @@ "Type": 10 }, "AppVersion": { - "Value": "4.0.22", + "Value": "4.0.24", "Type": 10 }, "Auto Compact": { From eae289b42e1d0d8aa0bc12d48dbdbcc5dda7f1ef Mon Sep 17 00:00:00 2001 From: Hecon5 <54177882+hecon5@users.noreply.github.com> Date: Thu, 19 Oct 2023 15:41:03 -0400 Subject: [PATCH 5/6] Update based on feedback from @joyfullservice. --- .../modules/clsPerformance.cls | 253 ++++-------------- 1 file changed, 57 insertions(+), 196 deletions(-) diff --git a/Version Control.accda.src/modules/clsPerformance.cls b/Version Control.accda.src/modules/clsPerformance.cls index 7ef5bc1f..17fd8bdf 100644 --- a/Version Control.accda.src/modules/clsPerformance.cls +++ b/Version Control.accda.src/modules/clsPerformance.cls @@ -96,7 +96,13 @@ Public Property Get CallStack() As String End Property - +'--------------------------------------------------------------------------------------- +' Procedure : CurrentCategoryName +' Author : hecon5 +' Date : 10/3/2023 +' Purpose : Return the current category name. +'--------------------------------------------------------------------------------------- +' Public Property Get CurrentCategoryName() As String CurrentCategoryName = this.CategoryName End Property @@ -134,11 +140,6 @@ 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 @@ -218,6 +219,18 @@ Public Sub OperationEnd(Optional lngCount As Long = 1) End Sub +'--------------------------------------------------------------------------------------- +' Procedure : CurrentOperationName +' Author : hecon5 +' Date : 10/3/2023 +' Purpose : Return the current operation's name. +'--------------------------------------------------------------------------------------- +' +Public Property Get CurrentOperationName() As String + CurrentOperationName = this.OperationName +End Property + + '--------------------------------------------------------------------------------------- ' Procedure : DigitsAfterDecimal ' Author : Eugen Albiker @@ -273,7 +286,9 @@ End Function '--------------------------------------------------------------------------------------- ' Private Sub StartTimer(dItems As Dictionary, strName As String) + Dim cItem As clsPerformanceItem + If Not dItems.Exists(strName) Then Set cItem = New clsPerformanceItem dItems.Add strName, cItem @@ -455,9 +470,6 @@ 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) @@ -493,202 +505,51 @@ End Function ' Author : Adam Waller ' Date : 11/3/2020 ' Purpose : List the result of a test in a fixed width format. The result strings -' : are positioned at the number of characters specified. +' : are positioned at the number of characters specified. If the heading size +' : exceeds the width of the column, the text will be wrapped. ' : I.e: ' : MyFancyTest 23 2.45 +' : My very long nam +' : e that I probabl +' : y should condens +' : e 12 3.23 '--------------------------------------------------------------------------------------- ' -Private 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 - - -Private 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 +Private Function ListResult(strHeading As String _ + , strResult1 As String _ + , strResult2 As String _ + , lngCol() As Long) As String - Dim Col1Rows As Long - Dim Col2Rows As Long - Dim Col3Rows As Long + Dim strRowHeading As String + Dim lngPos As Long + Dim intMax As Integer - Dim RowTotal As Long - Dim RowPosition As Long + ' Wrap at one character less than the column width + intMax = lngCol(0) - 1 - Dim strOutput As clsConcat - - On Error Resume Next - - 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 + ' Use concatenation class in case we need to deal with line wrapping + With New clsConcat - 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)) + ' Check for size overflow on heading. (Wrap on multiple lines) + strRowHeading = strHeading + If Len(strRowHeading) > intMax Then + lngPos = 1 + Do While lngPos + intMax <= Len(strHeading) + ' Add segment and linebreak + .Add Mid$(strHeading, lngPos, intMax), " ", vbCrLf + lngPos = lngPos + intMax + Loop + ' Get last heading line to use with results + strRowHeading = Mid$(strHeading, lngPos) 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 -End Function - - -Private Function MaxValue(ParamArray ValueIn() As Variant) As Variant - Dim Output As Variant - Dim ArrayPosition As Long - - ' Load the first value in to compare to. - Output = ValueIn(LBound(ValueIn)) - - For ArrayPosition = LBound(ValueIn) + 1 To UBound(ValueIn) - If Output < ValueIn(ArrayPosition) Then Output = ValueIn(ArrayPosition) - Next ArrayPosition - - MaxValue = Output -End Function - - -Private Function RoundUp(ByVal Value As Double) As Long - Dim lngVal As Long - Dim deltaValue As Double - - lngVal = CLng(Value) - deltaValue = lngVal - Value - - If deltaValue < 0 Then - RoundUp = lngVal + 1 - Else - RoundUp = lngVal - End If -End Function -Private Function RoundDown(ByVal Value As Double) As Long - Dim lngVal As Long - Dim deltaValue As Double - - lngVal = CLng(Value) - deltaValue = lngVal - Value - - If deltaValue <= 0 Then - RoundDown = lngVal - Else - RoundDown = lngVal - 1 - End If -End Function - - -'--------------------------------------------------------------------------------------- -' Procedure : FitStringToColumn -' Author : hecon5 -' Date : May 18, 2022 -' Purpose : Takes in a long string and returns an array of strings ColumnWidth wide. -'--------------------------------------------------------------------------------------- -' -Private 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 - 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: - FitStringToColumn = StrArr -End Function + ' Display heading and amounts + .Add PadRight(strRowHeading, lngCol(0)) + .Add PadRight(strResult1, lngCol(1)) + .Add strResult2 + ListResult = .GetStr + End With -Private 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 - - StrLen = Len(LongString) - If StrLen > MaxWidth Then - 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 - Else - FitStringToWidth = LongString - End If End Function @@ -700,7 +561,7 @@ End Function '--------------------------------------------------------------------------------------- ' Private Function PadRight(strText As String _ - , lngLen As Long _ + , lngLen As Long _ , Optional lngMinTrailingSpaces As Long = 1) As String Dim strResult As String @@ -746,7 +607,7 @@ Private Function SortItemsByTime(dItems As Dictionary) As Dictionary ' Build our list of records For Each varKey In dItems.Keys ' Create a record like this: "00062840.170000|Export Form Objects ..." - strRecord = Format(dItems(varKey).Total, "00000000.000000") & "|" & PadRight(CStr(varKey), 100) + strRecord = Format(dItems(varKey).Total, "00000000.000000") & "|" & PadRight(CStr(varKey), 255) ' Add to array. varItems(lngCnt) = strRecord ' Increment counter for array From 8c6d7f949e1a23e51b6d22073bd917659e4167d4 Mon Sep 17 00:00:00 2001 From: joyfullservice Date: Thu, 19 Oct 2023 15:18:28 -0500 Subject: [PATCH 6/6] Resolve conflict with upstream file Putting the comma after the argument seems to be the preferred industry-standard approach, based on ChatGPT and Bard. --- .../modules/clsPerformance.cls | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/Version Control.accda.src/modules/clsPerformance.cls b/Version Control.accda.src/modules/clsPerformance.cls index 17fd8bdf..aae14f60 100644 --- a/Version Control.accda.src/modules/clsPerformance.cls +++ b/Version Control.accda.src/modules/clsPerformance.cls @@ -96,6 +96,7 @@ Public Property Get CallStack() As String End Property + '--------------------------------------------------------------------------------------- ' Procedure : CurrentCategoryName ' Author : hecon5 @@ -515,10 +516,10 @@ End Function ' : e 12 3.23 '--------------------------------------------------------------------------------------- ' -Private Function ListResult(strHeading As String _ - , strResult1 As String _ - , strResult2 As String _ - , lngCol() As Long) As String +Private Function ListResult(strHeading As String, _ + strResult1 As String, _ + strResult2 As String, _ + lngCol() As Long) As String Dim strRowHeading As String Dim lngPos As Long @@ -560,9 +561,9 @@ End Function ' Purpose : Pads a string '--------------------------------------------------------------------------------------- ' -Private Function PadRight(strText As String _ - , lngLen As Long _ - , Optional lngMinTrailingSpaces As Long = 1) As String +Private Function PadRight(strText As String, _ + lngLen As Long, _ + Optional lngMinTrailingSpaces As Long = 1) As String Dim strResult As String Dim strTrimmed As String