VBA：代码因DoEvents而暂停时间长度变化

Posted 2023-01-16

我有一个程序，可以根据用户表单上提供的用户输入生成报告。我已经实现了错误处理，但是我的一个错误处理程序与DoEvents不能很好地协作。问题是我的主要子LoopGenrtReport，循环另一个子，GenerateReport，冻结了不同的时间长度，IF，GenerateReport子由于错误退出。我说不同长度，因为有时它是5秒，有时它永远不会移动到循环的下一次迭代。

我已经测试了删除进度条和Doevents的代码，并且在这样做时，我发现该过程完全按照预期工作。

我也测试过没有Application.Interactive，但是使用进度条和Doevents来查看是否可能是问题，但同样的事情发生了。

以下是代码：

Private Sub LoopGenrtReport(ByRef InPut_Array As Variant)

 Dim ii As Long
 Dim UBTailNum_Array As Long
 Dim Filtered_Array As Variant
 Dim LoopCounter As Long
 Dim pctdone As Single

   Application.ScreenUpdating = False
   Application.Interactive = False

        UBTailNum_Array = UBound(InPut_Array)

        'Sheet_Array is a public variable as are StartDate and End Date
        Filtered_Array = SubsetArray(Sheet_Array, StartDate, EndDate)

            If IsEmpty(Filtered_Array) Then
                MsgBox "No Transactions were found in the date range selected.", _
                vbCritical, "Error: No Transactions Found"
                GoTo ClearVariables
            End If

        'Release from memory
        Erase Sheet_Array

    'Show progress bar if more than one report _
    is being generated
    If UBTailNum_Array > 0 Then Call ShowPrgssBar

    For ii = LBound(InPut_Array) To UBound(InPut_Array)

            LoopCounter = LoopCounter + 1

            pctdone = LoopCounter / (UBTailNum_Array + 1)

            With FrmProgress
                .LabelCaption.Caption = "Generating Report(s) " & LoopCounter & " of " & UBTailNum_Array + 1
                .LabelProgress.Width = pctdone * (.FrameProgress.Width)
            End With
            DoEvents

            Call GenerateReport(Filtered_Array, CStr(InPut_Array(ii)))

    Next ii

ClearVariables:
    StartDate = Empty
    EndDate = Empty

    ii = Empty
    InPut_Array = Empty
    UBTailNum_Array = Empty
    Filtered_Array = Empty
    LoopCounter = Empty
    pctdone = Empty

    Application.Interactive = True
    Application.ScreenUpdating = True

End Sub

注意：仅当我因错误退出GenerateReport时才会出现此问题。实际错误是没有找到当前InPut_Array(ii)项目的交易。预期的行为是只在主要子中移动循环的下一次迭代而没有问题。如果退出被调用的子，则没有什么会影响主子。

我花了很长时间试图解决这个问题无济于事。任何想法，建议或答案将不胜感激。

根据@Spring Filip的请求，下面提供了被叫子的缩写版本GenerateReport。

Option Explicit
Option Private Module

Sub GenerateReport(ByRef Source_Array As Variant, ByRef KeyTailNum As String)

 Dim i As Long
 Dim CompositeKey As String
 Dim Dict1 As Dictionary
 Dim ItemComp_Array As Variant

 Dim Coll As Collection

    Set Dict1 = New Dictionary
        Dict1.CompareMode = TextCompare

    Set Coll = New Collection

            ' Build dictionary that summarizes transactions
            For i = LBound(Source_Array, 1) To UBound(Source_Array, 1)

                If Source_Array(i, 6) = KeyTailNum Then

                    CompositeKey = vbNullString

                    If Source_Array(i, 5) <> "MRO VENDOR" Then

                            If Source_Array(i, 5) = "ISSUE FROM STOCK" Then
                                'buid collection of IFS PNs
                                Coll.Add Source_Array(i, 1)
                            End If

                            'CompositeKey = PN,PO,Amount,Exp Type
                            CompositeKey = Join(Array(Source_Array(i, 1), _             
                                                Source_Array(i, 4), _
                                                Abs(Source_Array(i, 3)), _
                                                Source_Array(i, 5), KeyTailNum), "~~")

                            If Dict1.Exists(CompositeKey) Then

                                ItemComp_Array = Split(Dict1.Item(CompositeKey), "~~")

                                Dict1.Item(CompositeKey) = Join(Array(ItemComp_Array(0), _
                                                            ItemComp_Array(1), _
                                                            (CDbl(ItemComp_Array(2) + CDbl(Source_Array(i, 3)))), _
                                                            ItemComp_Array(3), _
                                                            ItemComp_Array(4), 0), "~~")

                            Else
                                'Item = PN, PN Des, Ammount, Exp Cat, Count, Place holder for averages  
                                Dict1.Add CompositeKey, Join(Array(Source_Array(i, 1), _
                                                            Source_Array(i, 2), _
                                                            CDbl(Source_Array(i, 3)), _
                                                            Source_Array(i, 5), _
                                                            1, 0), "~~")

                            End If

                    Else
                            'Key = Exp Alpha Name; PN/Exp Remark; Rec Unique ID; Tail Number
                            CompositeKey = Join(Array(Source_Array(i, 1), _
                                            Source_Array(i, 2), Source_Array(i, 7), KeyTailNum), "~~")

                            If Not Dict1.Exists(CompositeKey) Then

                                'Item = Exp Alpha Name; PN/Exp Remark; Amount; Exp Typ; Account;Rec Unique Id
                                Dict1.Add CompositeKey, Join(Array(Source_Array(i, 1), _
                                                            Source_Array(i, 2), _
                                                            CDbl(Source_Array(i, 3)), _
                                                            Source_Array(i, 5), _
                                                            Source_Array(i, 8), _
                                                            Source_Array(i, 7)), "~~")


                            End If

                    End If

                End If
            Next i

                'Errors_Coll is public, BoolExitGenRprt is public
                '**************************************************************************************************
                'Conditional Exit of Sub 
                '**************************************************************************************************
                'If there are no transactions found for this tail then go to the Next Tail Number if there is one
                If Dict1.Count = 0 Then
                    Errors_Coll.Add KeyTailNum
                    BoolExitGenRprt = True
                    GoTo ClearAllVariables
                End If
                '**************************************************************************************************
                '**************************************************************************************************


            'Begin Other code to be executed
            |
            |
            |
            |
            |
            |
            |
            |
            'End Other code to be excuted'


ClearAllVariables:
            'Clear Variables
            i = Empty
            Set Dict1 = Nothing
            CompositeKey = Empty
            ItemComp_Array = Empty
            Source_Array = Empty

End Sub

答案

@Enigmativity的评论让我质疑为什么我甚至首先使用DoEvents，所以我对自己说，“自我，如果你完全摆脱DoEvents并以10ms的增量使用Sleep Windows API函数而不是DoEvents？”好吧，这就是我所做的，添加了FrmProgress.Repaint，它可以防止Excel长时间冻结，同时更新进度条，就像我需要它一样。

唯一的问题是当由于我定义的错误而退出GenerateReport时，仍然存在一些滞后，但与之前的情况相比，我可以忍受它。

如果其他人有更好的想法，或者如果你认为我的想法不会像我希望的那样有效，那么请告诉我。我对其他想法或解决方案100％开放。

修改后的代码：

Private Sub LoopGenrtReport(ByRef InPut_Array As Variant)

 Dim ii As Long
 Dim UBTailNum_Array As Long
 Dim Filtered_Array As Variant
 Dim LoopCounter As Long
 Dim pctdone As Single

   Application.ScreenUpdating = False
   Application.Interactive = False

        UBTailNum_Array = UBound(InPut_Array)

        'Sheet_Array is a public variable as are StartDate and End Date
        Filtered_Array = SubsetArray(Sheet_Array, StartDate, EndDate)

            If IsEmpty(Filtered_Array) Then
                MsgBox "No Transactions were found in the date range selected.", _
                vbCritical, "Error: No Transactions Found"
                GoTo ClearVariables
            End If

        'Release from memory
        Erase Sheet_Array

    'Show progress bar if more than one report _
    is being generated
    If UBTailNum_Array > 0 Then Call ShowPrgssBar

    For ii = LBound(InPut_Array) To UBound(InPut_Array)

            LoopCounter = LoopCounter + 1

            pctdone = LoopCounter / (UBTailNum_Array + 1)

            With FrmProgress
                .LabelCaption.Caption = "Generating Report(s) " & LoopCounter & " of " & UBTailNum_Array + 1
                .LabelProgress.Width = pctdone * (.FrameProgress.Width)
            End With

            '***********************************
            'Added these in place of 'DoEvents'
            FrmProgress.Repaint
            Call Sleep (10)
            '***********************************

            Call GenerateReport(Filtered_Array, CStr(InPut_Array(ii)))

    Next ii

ClearVariables:
    StartDate = Empty
    EndDate = Empty

    ii = Empty
    InPut_Array = Empty
    UBTailNum_Array = Empty
    Filtered_Array = Empty
    LoopCounter = Empty
    pctdone = Empty

    Application.Interactive = True
    Application.ScreenUpdating = True

End Sub

Windows API函数/ subs：

#If VBA7 Then 
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)

#Else

    Public Declare Sub Sleep Lib "kernel32" (ByVal Milliseconds As Long)

#End If