Find Emails with Attachments

[MattehWoo]

Hi all,

I have the following code, it's supposed to find emails in a mailbox with certain attachements and move them to a specific folder. It works for only 1 email before the debugger comes up, you have to end it, and run it again to do the next one, and so on...

Can anyone see where i'm going wrong?


Public iItem As Integer
Option Explicit


Sub MovePhotosToFolder()

Dim oItem As MailItem
Dim FileName As String
Dim receiveddatetime As String
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace
Dim emailsub As String
Dim Atts As Attachments
Dim Att As Attachment
Dim i As Long

Set objNS = Application.GetNamespace("MAPI")
Set objSourceFolder = objNS.Folders.item("Mailbox - ****").Folders.item("Inbox")
Set objDestFolder = objNS.Folders.item("Mailbox - ****").Folders.item("Inbox").Folders.item("Photos")

If objSourceFolder.Items.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If

For i = objSourceFolder.Items.Count To 1 Step -1
Set oItem = objSourceFolder.Items(i)


receiveddatetime = Format(oItem.ReceivedTime, "yyyy-mm-dd")


If InStr(LCase(oItem.Subject), "photo") > 0 Then

Set Atts = oItem.Attachments

If Atts.Count > 0 Then
For Each Att In Atts
If InStr(LCase(Att.FileName), "job") > 0 Then
FileName = "\\****\****\Photos\" & receiveddatetime & "\"
On Error Resume Next


MkDir "\\****\****\Photos\" & receiveddatetime & "\"
On Error GoTo 0

Att.SaveAsFile FileName & Att.FileName
oItem.Move objDestFolder


End If
Next
End If
End If
Next



End Sub

[OBP]

The first problem is you do not have any error trapping, without it you will not necessarily get the correct error message or sometimes none at all.
So add some error trapping so that you can tell us what has gone wrong with the code.