For Each loop not getting all Email Items

[Hunter57]

I am using Access 2003 to Automate Outlook and archive Email as msg files to
the hard drive. The For Each loop (For Each objitm In objFolder.Items) in my
code does not find all of the emails and I am unable to find out why this is
happening. It only finds about half of the emails in the Outlook folder.

Everything else appears to be working properly.

Private Sub cmdSetAchiveFolder_Click()

Dim objApp As Object
Dim objNS As Object 'NameSpace
Dim colFolders As Object ' Outlook.Folders
Dim objFolder As Object ' Outlook.MAPIFolder
Dim objitm As Object
Dim objMail As Object
Dim strAppTitle As String ' Application Window Title
Dim strFolderPath As String
Dim strArchiveFolder As String
Dim arrFolders() As String
Dim i As Long

' Get the Folder name where the emails will be archived
strArchiveFolder = Me.cboDestinationFolder.Value

' Get the Outlook Folder Path
strFolderPath = Me.txtOutlookFolder.Value

If isAppThere("Outlook.Application") = False Then
' Outlook is not open, create a new instance
Set objApp = CreateObject("Outlook.Application")
Else
' Outlook is already open--use this method
Set objApp = GetObject(, "Outlook.Application")
End If

Set objNS = objApp.GetNamespace("MAPI")

' Get the folder by the Folder Path
On Error Resume Next

strFolderPath = Replace(strFolderPath, "/", "\")
' Eliminate any leading "\" from the string
Do While Left(strFolderPath, 1) = "\"
strFolderPath = Right(strFolderPath, (Len(strFolderPath) - 1))
Loop

arrFolders() = Split(strFolderPath, "\")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If

If Not objFolder Is Nothing Then

This is the loop where the problem occurs:
For Each objitm In objFolder.Items
Debug.Print "Email " & objitm.Subject & " was found."
' Outlook.OlObjectClass Const olMail = 43 (&H2B)
If objitm.Class = 43 Then
Set objMail = objitm
End If
' Call a Procedure to Save the Email to the Archive Folder
Call ArchiveEmails(objMail, strArchiveFolder)
' Delete the email
If blnArchived = True Then
Debug.Print "Email " & objMail.Subject & " was archived."
objMail.Delete
Else
Debug.Print "Email " & objMail.Subject & " was not deleted."
End If
Next objitm
End If

Set objMail = Nothing
Set objitm = Nothing
Set objFolder = Nothing
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing

End Sub

 

[Eric Legault [MVP - Outlook]]

You're not the only one who has encountered this issue - nearly every Outlook
developer comes across this at some point!

The problem is you are deleting e-mails, thus altering the population of the
collection and affecting the loop.

The trick is to count backwards - e.g.:

For intX = objItems.Count To 1 Step -1
...
Set objMail = objItems.Item(intX)
objMail.Delete
...
Next

 

[Hunter57]

Hi Eric,

Thanks for the help. Of course. Now it makes sense. I suppose I did not
think of that because I was using a For Each loop instead of stepping through
an index.

Best Regards,
Patrick Wood

 

[Hunter57]

Hi Eric,

It works great! Many thanks.

Pat Wood

You're not the only one who has encountered this issue - nearly every Outlook
developer comes across this at some point!

The problem is you are deleting e-mails, thus altering the population of the
collection and affecting the loop.

The trick is to count backwards - e.g.:

For intX = objItems.Count To 1 Step -1
...
Set objMail = objItems.Item(intX)
objMail.Delete
...
Next

--
Eric Legault - Outlook MVP, MCDBA, MCTS (SharePoint programming, etc.)
Try Picture Attachments Wizard for Outlook:
http://www.collaborativeinnovations.ca
Blog: http://blogs.officezealot.com/legault/