MattehWoo
07-26-2017, 04:49 AM
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
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