我有一个 VBA 宏来搜索电子邮件文件。
当搜索数万封电子邮件时(在我的测试机器上甚至只有几百封),它会显示几秒钟的状态,然后在搜索其余电子邮件时进入“无响应”状态。
这导致不耐烦的用户过早地结束了任务,我想通过提供状态更新来纠正这个问题。
我编写了以下解决方案,并认为问题出在循环期间 VBA 中 GarbageCollector 的运行方式上。
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
最佳答案
换行
UserForm1.Repaint
到
DoEvents
是的,这会增加执行时间,但如果有数千封电子邮件,那么您就别无选择。
提示: 你也可能想改变
StatusBarMsg = "Processing "& x & "out of "& initialCount & "条消息。"
到
StatusBarMsg = "请不要打断。正在处理 "& x & "out of "& initialCount & "消息。"
此外,建议您在流程开始时告知您的用户这可能需要一些时间,因此他们可以在确定不想在该电脑上工作时运行该流程?
像这样
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
希德
关于vba - 为在完成前进入无响应状态的宏提供状态更新,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/9622983/