looping through the Inbox to process emails

[SUZYQ]

I am trying to loop through the emails in my Inbox and then move the
emails depending on whether they have excel attachments.

For some reason this code will not loop properly through the Inbox. It
processes the first email but when it hits the Next statement it seems
to ignore it and keep going. I've even tested the olInboxItems.Count
and am given a number higher than 1.

I've put the code below...


Sub GetDefaultFolder()

On Error GoTo ErrorHandler

Dim ol As Outlook.Application
Dim olns As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Dim myFolder As Outlook.MAPIFolder
'Dim mItem As Outlook.MailItem
Dim objMess As Object
Dim i As Integer
Dim strDestination As String
Dim objMoveFolder As Outlook.MAPIFolder
Dim intExcel As Integer
Dim olInboxItems As Outlook.Items

Set ol = New Outlook.Application
Set olns = ol.GetNamespace("MAPI")
Set myRecipient = olns.CreateRecipient("John Smith")

intExcel = 0

myRecipient.Resolve
If myRecipient.Resolved Then
Set myFolder = olns.GetSharedDefaultFolder(myRecipient,
olFolderInbox)
Set olInboxItems = olns.GetSharedDefaultFolder(myRecipient,
olFolderInbox).Items

For Each objMess In olInboxItems
If objMess.Attachments.Count > 0 Then
'there are attachments to strip
For i = 1 To objMess.Attachments.Count
'save Excel file
If Right(objMess.Attachments.Item(i).DisplayName, 4) =
".xls" Then
objMess.Attachments.Item(i).SaveAsFile
strDestination & _
objMess.Attachments.Item(i).DisplayName
intExcel = intExcel + 1
End If

'move the file to another folder
If intExcel > 0 Then 'there's at least one Excel
attachment
Set objMoveFolder = myFolder.Folders("Processed
Pinks")
objMess.Move objMoveFolder
Else
Set objMoveFolder = myFolder.Folders("No
Attachments")
objMess.Move objMoveFolder
End If
Next i
Else
'move the file to another folder
Set objMoveFolder = myFolder.Folders("No Attachments")
objMess.Move objMoveFolder
End If
Next objMess
Else
MsgBox "Cannot resolve " & myRecipient, vbOKOnly + vbCritical,
"Outlook Error"

End If

ExitSub:
MsgBox "complete"
Set ol = Nothing
Set olns = Nothing
Set myRecipient = Nothing
Exit Sub

ErrorHandler:
MsgBox Err.Number & vbCrLf & Err.Description
Resume ExitSub

End Sub

 

[Wayman Bell]

Try the code from this web site. I made a couple of minor changes to make it
save to three different folders and it works beautifully for me on the first
run.

I get to work and in fifteen minutes I had processed 1000 emails with 1800
attachments and saved the excel attachments to one folder, the jpg
attachments to another and all other attachment to a third.

http://www.fontstuff.com/outlook/oltut01.htm

Now I have added another module that loops through all of the excel files
saved previously and extracts all the data from them one by one and pastes
it into a single spreadsheet. This use to take me 10-12 hours to process.

Sorry but I'm not good enough with code yet to tell what may be the problem
with the code you posted.

Wayman