For Each loop not getting all Email Items

Status
Not open for further replies.
H

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
 
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 - , MCDBA, MCTS (SharePoint programming, etc.)

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

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.

Patrick Wood

"Eric Legault " wrote:


> 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 - , MCDBA, MCTS (SharePoint programming, etc.)
>

>

>

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

Hunter57

Hi Eric,

It works great! Many thanks.

Pat Wood

"Eric Legault " wrote:


> 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 - , MCDBA, MCTS (SharePoint programming, etc.)
>

>

>

> "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
> >
 
Status
Not open for further replies.
Top