For Each loop not getting all Email Items

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

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/


"Hunter57" wrote:

> 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
>