Provide status updates for a macro that goes unresponsive before completion
I have a VBA macro for searching email archives.
When searching through tens of thousands of emails (or even just a couple hundred on my test machine) it displays the status for a few seconds and then goes into a non-responder state while working on the rest of the messages.
This caused impatient users to close the issue prematurely and I would like to fix this by providing status updates.
I have coded the following solution and I believe that the problem lies with the way the GarbageCollector functions in VBA during a loop.
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
source to share
Change the line
Yes, this will increase the execution time, but in case there are thousands of emails, you have little option.
Tip: You can also change
StatusBarMsg = "Processing " & x & " out of " & initialCount & " messages."
StatusBarMsg = "Please do not interrupt. Processing " & x & " out of " & initialCount & " messages."
It is also advisable to inform your user at the beginning of the process that it may take a while, and therefore they can start the process when they are sure that they do not want to work on this computer?
Something like that
Sub Sample() Dim strWarning As String Dim Ret strWarning = "This process may take sometime. It is advisable to run this " & _ 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
source to share