Outlook macro runs through 250 iterations before failing with error

Question

Description:

I have an Outlook macro that loops through selected emails in a folder and writes down some info to a .csv file. It works perfectly up until 250 before failing. Here is some of the code:

Open strSaveAsFilename For Append As #1

CountVar = 0
For Each objItem In Application.ActiveExplorer.Selection
    DoEvents
    If objItem.VotingResponse <> "" Then
        CountVar = CountVar + 1
        Debug.Print "   " & CountVar & ". " & objItem.SenderName
        Print #1,  & objItem.SenderName & "," &  objItem.VotingResponse
    Else
        CountVar = CountVar + 1
        Debug.Print "   " & CountVar & ". " & "Moving email from: " & Chr(34) & objItem.SenderName & Chr(34) & " to: Special Cases sub-folder"
        objItem.Move CurrentFolderVar.Folders("Special Cases")
    End If
Next
Close #1

Problem

After this code runs through 250 emails, the following screenshot pops up:

http://i.stack.imgur.com/yt9P8.jpg

I've tried adding a "wait" function to give the server a rest so that I'm not querying it so quickly, but I get the same error at the same point.

Answer 1

Thanks to @76mel, for his answer to another question which I referenced heavily. I found out that it is a built-in limitation in Outlook (source) that you can't open more than 250 items and Outlook keeps them all in memory until the macro ends no matter what. The workaround, instead of looping through each item in selection:

For Each objItem In Application.ActiveExplorer.Selection

you can loop through the parent folder. I thought I could do something like this:

For Each objItem In oFolder.Items

but, it turns out that when you delete or move an email, it shifts the list up one, so it will skip emails. The best way to iterate through a folder that I found in another answer is to do this:

For i = oFolder.Items.Count To 1 Step -1 'Iterates from the end backwards
Set objItem = oFolder.Items(i)

Here is the whole code, which prompts for a folder to choose to parse, creates sub-directories in that folder for "Out of Office" replies as well as "Special Cases" where it puts all emails that begin with "RE:"

Sub SaveItemsToExcel()
    Debug.Print "Begin SaveItemsToExcel"

    Dim oNameSpace As Outlook.NameSpace
    Set oNameSpace = Application.GetNamespace("MAPI")
    Dim oFolder As Outlook.MAPIFolder
    Set oFolder = oNameSpace.PickFolder
    Dim IsFolderSpecialCase As Boolean
    Dim IsFolderOutofOffice As Boolean
    IsFolderSpecialCase = False
    IsFolderOutofOffice = False

    'If they don't check a folder, exit.
    If oFolder Is Nothing Then
        GoTo ErrorHandlerExit
    ElseIf oFolder.DefaultItemType <> olMailItem Then 'Make sure folder is not empty
        MsgBox "Folder does not contain mail messages"
        GoTo ErrorHandlerExit
    End If

    'Checks to see if Special Cases Folder and Out of Office folders exists. If not, create them
    For i = 1 To oFolder.Folders.Count
        If oFolder.Folders.Item(i).name = "Special Cases" Then IsFolderSpecialCase = True
        If oFolder.Folders.Item(i).name = "Out of Office" Then IsFolderOutofOffice = True
    Next
    If Not IsFolderSpecialCase Then oFolder.Folders.Add ("Special Cases")
    If Not IsFolderOutofOffice Then oFolder.Folders.Add ("Out of Office")

    'Asks user for name and location to save the export
    objOutputFile = CreateObject("Excel.application").GetSaveAsFilename(InitialFileName:="TestExport" & Format(Now, "_yyyymmdd"), fileFilter:="Outlook Message (*.csv), *.csv", Title:="Export data to:")
    If objOutputFile = False Then Exit Sub
    Debug.Print "   Will save to: " & objOutputFile & Chr(10)

    'Overwrite outputfile, with new headers.
    Open objOutputFile For Output As #1
    Print #1, "User ID,Last Name,First Name,Company Name,Subject,Vote Response,Recived"

    ProcessFolderItems oFolder, objOutputFile

    Close #1

    Set oFolder = Nothing
    Set oNameSpace = Nothing
    Set objOutputFile = Nothing
    Set objFS = Nothing

    MsgBox "All complete! Emails requiring attention are in the " & Chr(34) & "Special Cases" & Chr(34) & " subdirectory."
    Debug.Print "End SaveItemsToExcel."
    Exit Sub
ErrorHandlerExit:
    Debug.Print "Error in code."
End Sub

Sub ProcessFolderItems(oParentFolder, ByRef objOutputFile)
    Dim oCount As Integer
    Dim oFolder As Outlook.MAPIFolder
    Dim MessageVar As String
    oCount = oParentFolder.Items.Count
    Dim CountVar As Integer
    Dim objItem As Outlook.MailItem

    CountVar = 0

    For i = oParentFolder.Items.Count To 1 Step -1 'Iterates from the end backwards
    Set objItem = oParentFolder.Items(i)
        DoEvents
        If objItem.Class = olMail Then
            If objItem.VotingResponse <> "" Then
                CountVar = CountVar + 1
                Debug.Print "   " & CountVar & ". " & GetUsername(objItem.SenderName, objItem.SenderEmailAddress) & "," & objItem.SenderName & "," & GetCompany(objItem.SenderName) & "," & Replace(objItem.Subject, ",", "") & "," & objItem.VotingResponse & "," & objItem.ReceivedTime
                Print #1, GetUsername(objItem.SenderName, objItem.SenderEmailAddress) & "," & objItem.SenderName & "," & GetCompany(objItem.SenderName) & "," & Replace(objItem.Subject, ",", "") & "," & objItem.VotingResponse & "," & objItem.ReceivedTime
            ElseIf objItem.Subject Like "*Out of Office*" Then
                CountVar = CountVar + 1
                Debug.Print "   " & CountVar & ". " & "Moving email from: " & Chr(34) & objItem.SenderName & Chr(34) & " to the, " & Chr(34) & "Out of Office" & Chr(34) & " sub-folder"
                objItem.Move oParentFolder.Folders("Out of Office")
            Else
                CountVar = CountVar + 1
                Debug.Print "   " & CountVar & ". " & "Moving email from: " & Chr(34) & objItem.SenderName & Chr(34) & " to the, " & Chr(34) & "Special Cases" & Chr(34) & " sub-folder"
                objItem.Move oParentFolder.Folders("Special Cases")
            End If
        End If
    Next i
    Set objItem = Nothing
End Sub

Function GetUsername(SenderNameVar As String, SenderEmailVar As String) As String
    On Error Resume Next
    GetUsername = ""
    GetUsername = CreateObject("Outlook.Application").CreateItem(olMailItem).Recipients.Add(SenderNameVar).AddressEntry.GetExchangeUser.Alias
    If GetUsername = "" Then GetUsername = Mid(SenderEmailVar, InStrRev(SenderEmailVar, "=", -1) + 1)
End Function

Function GetCompany(SenderNameVar)
    On Error Resume Next
    GetCompany = ""
    GetCompany = CreateObject("Outlook.Application").CreateItem(olMailItem).Recipients.Add(SenderNameVar).AddressEntry.GetExchangeUser.CompanyName
End Function

Answer 2

To solve this problem I used the following rules:

the "objOutlook.ActiveExplorer" has limited range (250 objects).

but object create for each email is unlimited.

for exemple:

sub Over250()

  Total = objOutlook.ActiveExplorer.Selection.Count

  For X = 1 to Total

    Set objOutlook = CreateObject("Outlook.Application")
    Set ObjExplorer = objOutlook.ActiveExplorer     

   '**** DO YOU THINGS****

    Set objOutlook = Nothing
    Set ObjExplorer = Nothing

  Next X

end sub