Moving over 20,000 emails, based on email address, freezes Outlook

Question

I am trying to move over 20,000 emails, based on email address, into desired folders.

The code I found freezes Outlook. The code does work before the freeze.

Using first code from the answer to this post

Option Explicit
Public Sub Move_Items()
'   // Declare your Variables
    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder
    Dim olNs As Outlook.NameSpace
    Dim Item As Object
    Dim Items As Outlook.Items
    Dim lngCount As Long

    On Error GoTo MsgErr
'    Set Inbox Reference
    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items

'   // Loop through the Items in the folder backwards
    For lngCount = Items.Count To 1 Step -1
        Set Item = Items(lngCount)

        If Item.Class = olMail Then
            Select Case Item.SenderEmailAddress

'               // Email_One
                Case "Email_One@email.com"
'                   // Set SubFolder of Inbox
                    Set SubFolder = Inbox.Folders("Folder One")
                    Set Item = Items.Find("[SenderEmailAddress] = 'Email_One@email.com'")
                    If TypeName(Item) <> "Nothing" Then
'                       // Mark As Read
                        Item.UnRead = False
'                       // Move Mail Item to sub Folder
                        Item.Move SubFolder
                    End If

'               // Email_Two
                Case "Email_Two@email.com"
'                   // Set SubFolder of Inbox
                    Set SubFolder = Inbox.Folders("Folder Two")
                    Set Item = Items.Find("[SenderEmailAddress] = 'Email_Two@email.com'")
                    If TypeName(Item) <> "Nothing" Then
'                       // Mark As Read
                        Item.UnRead = False
'                       // Move Mail Item to sub Folder
                        Item.Move SubFolder
                    End If

            End Select
        End If
    Next lngCount

MsgErr_Exit:
    Set Inbox = Nothing
    Set SubFolder = Nothing
    Set olNs = Nothing
    Set Item = Nothing
    Set Items = Nothing

    Exit Sub

'// Error information
MsgErr:
    MsgBox "An unexpected Error has occurred." _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume MsgErr_Exit
End Sub

Also is it possible to filter not a specific email address e.g. dave@test.com but *@test.com?

sjb · Answer 1 · 2021-03-23T06:52:10.117

I think at least your first problem might be the line 'Set Inbox = olNs.GetDefaultFolder(olFolderInbox)'

I have the similar line 'Set Items = objNS.GetDefaultFolder(olFolderInbox).Items' in my start-up routine Private Sub Application_Startup() . This worked fine ever since we switched to 365, but then circa February 2021 it started to crash on start-up. I got here by searching on this problem. Presumably they have changed something about the object model.

I also suppose it could be where olNs is set in the first place ' Set objNS = olApp.GetNamespace("MAPI"), if you mail doesn't use MAPI?

I've chucked the problem at out IT support, and I'll let you know if they come back with anything other than a mildly panicked 'what the hell you doing using VBA?'

score 0 · Answer 2 · answered Mar 23 '21 at 17:32

The delay is caused by running a time-consuming task/code in Outlook. So, you need to optimize what and how is run in Outlook.

The problem is in the source code. I've noticed that you are iterating over all items in the folder:

// Loop through the Items in the folder backwards
    For lngCount = Items.Count To 1 Step -1

That is completely a bad idea!

Instead, you need to use the Find/FindNext or Restrict methods to process all items that correspond to the specified search criteria. The Find method returns a single and first entry from the list of items. To get the second (if any) you need to use the FindNext method in the loop.

Read more about these methods in the following articles:

Also you may consider using the AdvancedSearch method of the Application class. The key benefits of using the AdvancedSearch method in Outlook are:

The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
You can stop the search process at any moment using the Stop method of the Search class.

See Advanced search in Outlook programmatically: C#, VB.NET for more information.

I am going to read up on those and try those, they seem to be better but I just need to incorporate it in the code in a proper way, thank you. The DoEvents give me a Error 440 — Sushant Nanda, Mar 24 '21 at 02:51

score 0 · Answer 3 · answered Mar 24 '21 at 14:12

If processing every item there is no need for a Find. Find replaces the For loop item. It is more likely to run to completion when there are fewer items.

The simplest change is to remove the Find. This should fix any array out of bounds errors. Still it is inefficient.

// Email_One
Case "Email_One@email.com"
    '// Set SubFolder of Inbox
    Set SubFolder = Inbox.Folders("Folder One")
    '// Mark As Read
    Item.UnRead = False
    '// Move Mail Item to sub Folder
    Item.Move SubFolder

One way to limit processing to the applicable items.

Option Explicit


Public Sub Move_Items_Restrict()

    '// Declare your Variables
    Dim myInbox As Folder
    Dim subFolder As Folder
    
    Dim myItem As Object
    Dim myItems As Items
    Dim resItems As Items
    
    Dim strfilter As String
    Dim i As Long

    ' Not while developing
    'On Error GoTo MsgErr
    
    ' Set Inbox Reference
    Set myInbox = Session.GetDefaultFolder(olFolderInbox)

    '// Email_One
    Set myItems = myInbox.Items
    
    strfilter = "[SenderEmailAddress] = 'Email_One@email.com'"
    Debug.Print strfilter

    ' some of these work, fromemail does
    ' https://learn.microsoft.com/en-us/previous-versions/office/developer/exchange-server-2007/aa579702(v=exchg.80)    
    'strfilter = "@SQL=urn:schemas:httpmail:fromemail LIKE '%@test.com'"
    'Debug.Print strfilter

    Set resItems = myItems.Restrict(strfilter)
    Debug.Print resItems.count
    
    If resItems.count > 0 Then
    
        '// Set SubFolder of Inbox
        Set subFolder = myInbox.folders("Folder One")

        For i = resItems.count To 1 Step -1
        
            Set myItem = resItems(i)
            
            With myItem
                '// Mark As Read
                .UnRead = False
                
                '// Move Mail Item to sub Folder
                .Move subFolder
            End With
            
            ' If there is a memory error,
            '  release item when no longer necessary,
            'Set myItem = Nothing
        
        Next
    
    End If
    
    
    '// Email_Two
    Set myItems = myInbox.Items
    
    strfilter = "[SenderEmailAddress] = 'Email_Two@email.com'"
    Debug.Print strfilter

    Set resItems = myItems.Restrict(strfilter)
    Debug.Print resItems.count
    
    If resItems.count > 0 Then
    
        '// Set SubFolder of Inbox
        Set subFolder = myInbox.folders("Folder Two")

        For i = resItems.count To 1 Step -1
        
            Set myItem = resItems(i)
            
            With myItem
    '           // Mark As Read
                .UnRead = False
                
    '           // Move Mail Item to sub Folder
                .Move subFolder
            End With
            
            ' If there is a memory error,
            '  release item when no longer necessary,
            'Set myItem = Nothing
        
        Next
    
    End If

MsgErr_Exit:
    Exit Sub

'// Error information for users to advise the developer
MsgErr:
    MsgBox "An unexpected Error has occurred." _
         & vbCrLf & "Error Number: " & err.Number _
         & vbCrLf & "Error Description: " & err.description _
         , vbCritical, "Error!"
    Resume MsgErr_Exit
    
End Sub

This works super clean, but my issue is, it only worked for instagram.com but failed to do with wish.com and wordpress.com, why does it show 0 count for an email like offers@wish.com when I see like 3 emails in the past week for it. But for Instagram which had 99 emails, it was super quick to move all of it instantly to the folder? — Sushant Nanda, Mar 25 '21 at 00:26
Verify the value in `.SenderEmailAddress` is what you think it is. If the same you could ask a new question. — niton, Mar 26 '21 at 14:13

Moving over 20,000 emails, based on email address, freezes Outlook

3 Answers3