提供进入无响应状态直到完成的宏的状态更新

Question

我有一个VBA宏来搜索电子邮件存档。

当通过数以万计的电子邮件（甚至在我的测试机上仅有几百个电子邮件）进行搜索时，它会显示状态几秒钟，然后在运行其他电子邮件时进入“未响应”状态。

这导致急躁的用户过早地关闭了任务，我想通过提供状态更新来纠正此问题。

我已经编码了下面的解决方案，并认为问题在于Loop中GarbageCollector在VBA中的作用方式。

Public Sub searchAndMove() 

    UserForm1.Show 

    ' Send a message to the user indicating 
    ' the program has completed successfully, 
    ' and displaying the number of messages sent during the run. 

End Sub 

Private Sub UserForm_Activate() 

Me.Width = 240 
Me.Height = 60 

Me.Label1.Width = 230 
Me.Label1.Height = 50 

Dim oSelectTarget As Outlook.Folder 
Dim oMoveTarget As Outlook.Folder 
Dim oSearchCriteria As String 

' Select the target folder to search and then the folder to 
' which the files should be moved 
Set oSelectTarget = Application.Session.PickFolder 
Set oMoveTarget = Application.Session.PickFolder 

oSearchCriteria = InputBox("Input search string: ") 

Dim selectedItems As Outlook.Items 
Set selectedItems = oSelectTarget.Items 
Dim selectedEmail As Outlook.MailItem 

Dim StatusBarMsg As String 
StatusBarMsg = "" 

Dim initialCount As Long 
initialCount = selectedItems.count 


Dim movedCounter As Long 
movedCounter = 0 
Dim x As Long 
Dim exists As Long 

' Function Loop, stepping backwards 
' to prevent errors derived from modifying the collection 
For x = selectedItems.count To 1 Step -1 
    Set selectedEmail = selectedItems.Item(x) 
    ' Test to determine if the subject contains the search string 

    exists = InStr(selectedEmail.Subject, oSearchCriteria) 
    If Len(selectedEmail.Subject) > 999 Then 
     selectedEmail.Move oMoveTarget 
    Else: 
     If exists <> 0 Then 
      selectedEmail.Move oMoveTarget 
      movedCounter = (movedCounter + 1) 
     Else: End If 
    End If 
    Set selectedEmail = Nothing 
    StatusBarMsg = "Processing " & x & " out of " & initialCount & " messages." 

    UserForm1.Label1.Caption = StatusBarMsg 
    UserForm1.Repaint 
Next x 

Dim Msg As String 
Dim Response 
Msg = "SearchAndMove has detected and moved " & movedCounter & _ 
    " messages since last run." 
Response = MsgBox(Msg, vbOKOnly) 


' Close the References to prevent a reference leak 
Set oSelectTarget = Nothing 
Set oMoveTarget = Nothing 
Set selectedItems = Nothing 
Set selectedEmail = Nothing 

Unload Me 

End Sub 

Answer 1

更改线路

UserForm1.Repaint

到

DoEvents

是的，这会增加执行时间，但万一有成千上万的电子邮件，那么你不必很多选项。

提示： 你也可能要改变

StatusBarMsg = "Processing " & x & " out of " & initialCount & " messages."

到

StatusBarMsg = "Please do not interrupt. Processing " & x & " out of " & initialCount & " messages."

而且最好是在过程的开始，告知您的用户，它可能需要时间，因此他们可以在确定他们不想在该PC上工作时运行该流程？

像这样的事情

Sub Sample() 
    Dim strWarning As String 
    Dim Ret 

    strWarning = "This process may take sometime. It is advisable to run this " & _ 
    "when you don't intend to use the pc for sometime. Would you like to Continue?" 

    Ret = MsgBox(strWarning, vbYesNo, "Information") 

    If Ret <> vbYes Then Exit Sub 

    For x = SelectedItems.Count To 1 Step -1 

    '~~> Rest of the code 
End Sub 

HTH

希德