VBA：使用 DoEvents 时长不同的代码暂停
VBA: Code Pauses For Varying Lengths of Time With DoEvents
我有一个程序可以根据用户表单上提供的用户输入生成报告。我已经实现了错误处理，这是应该的，但是我的错误处理程序之一不能很好地与 DoEvents 配合使用。问题是我的主子 LoopGenrtReport 循环另一个子 GenerateReport，冻结了不同的时间长度，如果 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, Amount, 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，所以我对自己说，"Self, What if you just get rid of DoEvents altogether and use the Sleep Windows API function at a 10ms increment instead of 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 Functions/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
我有一个程序可以根据用户表单上提供的用户输入生成报告。我已经实现了错误处理，这是应该的，但是我的错误处理程序之一不能很好地与 DoEvents 配合使用。问题是我的主子 LoopGenrtReport 循环另一个子 GenerateReport，冻结了不同的时间长度，如果 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, Amount, 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，所以我对自己说，"Self, What if you just get rid of DoEvents altogether and use the Sleep Windows API function at a 10ms increment instead of 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 Functions/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