OUTLOOK VBA move email from one sub folder to another

[Chris_AAA]

Hi

I am completely new to OUTLOOK VBA.

I am only learning the bare basics....

I have set up a code which extracts the attachments to my local drive, which works fine.

However I need to know, and understand that once I have extracted said emails from sub folder (Z folder) it then moves into my other sub folder (_Reviewed)

Thank you kindly

[skatonni]

http://msdn.microsoft.com/en-us/library/office/ff860683(v=office.15).aspx

You will have something like this


Set myDestFolder = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("_Reviewed")
myItem.Move myDestFolder

[Chris_AAA]

Thanks so much for your reply...

I added the code to the bottom of my previous code (apologies - perhaps I should of given that in the first place)


Sub Email()
On Error GoTo extraction_err
Dim Ns As NameSpace
Dim Item As Object
Dim subfolder As MAPIFolder
Dim atmt As Attachment
Dim filename As String
Dim i As Integer
Set Ns = GetNamespace("MAPI")
Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
Set subfolder = Inbox.Folders("Z EXAMPLE")
i = 0
If subfolder.Items.Count = 0 Then
MsgBox "This folder has No Messages." _
, vbInformation, "Nothing Found"
Exit Sub
End If
If subfolder.Items.Count > 0 Then
For Each Item In subfolder.Items
For Each atmt In Item.Attachments
filename = "C:\EXAMPLE.csv"
atmt.SaveAsFile filename
'If item.fileexists("atmt.filename") Then
'filename = "C:\Email Attachments" & _
'Format(item.CreationTime, "yyyymmdd_hhnnss_") & atmt.filename
'End If
i = i + 1
Next atmt
Next Item
End If
If i > 0 Then
MsgBox "Found " & i & " attached files." _
& vbCrLf & "Saved to designated folder" _
, vbInformation, "finished!"
Else
MsgBox "There was no files attached to these emails.", vbInformation, _
"finished!"
End If
extraction_exit:
Set atmt = Nothing
Set Item = Nothing
Set Ns = Nothing
Exit Sub
extraction_err:
MsgBox "An unexpected error has occured." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: extraction" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume extraction_exit
'Moves Email into reviewed folder.
Set myDestFolder = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("_Reviewed")
myItem.Move myDestFolder
Exit Sub
End Sub



So in esscence, after I have extracted the attatchment I would like the email in ZExample folder to then feed into _Reviewed folder.

I just re run the macro with the new added code as per above, and it does not move the email to _Reviewed folder.

Thank you for the code though, its helped me get a rough idea of what im looking for, if you can see the above and see where i have gone wrong that would be amazing.

[westconn1]

probably you should move each item immediately after saving the attachment
BUT if you remove items from the collection while looping through the collection, not all items will be processed
so you should instead of using for each item, use
For counter = subfolder.items.count to 1 step -1
Set item = subfolder.items(counter)
items removed from the bottom of a collections do not upset the indexes

[skatonni]

There is an Exit Sub before you can get to your added code. You may not have noticed this advice. "To debug, mouse-click anywhere in the code. Press F8 repeatedly to step through the code. http://www.cpearson.com/excel/DebuggingVBA.aspx"

This untested code shows where moving would occur inside the Item loop and incorporates reverse moving.


Option Explicit

Sub Email()
On Error Goto extraction_err
Dim Ns As NameSpace
Dim Item As Object
Dim subfolder As MAPIFolder
Dim atmt As Attachment
Dim filename As String
Dim i As Integer

Dim Counter as Long
Dim DestFolder As MAPIFolder

Set Ns = GetNamespace("MAPI")
Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
Set subfolder = Inbox.Folders("Z EXAMPLE")

i = 0
If subfolder.Items.Count = 0 Then
MsgBox "This folder has No Messages." _
, vbInformation, "Nothing Found"
Exit Sub
End If

If subfolder.Items.Count > 0 Then
'Does not work correctly in VBA when reducing the collection
'For Each Item In subfolder.Items ' <--- Commented out.

For counter = subfolder.items.count to 1 step -1 ' <--- Reverse order when deleting or moving
Set item = subfolder.items(counter)

For Each atmt In Item.Attachments
filename = "C:\EXAMPLE.csv"
atmt.SaveAsFile filename
'If item.fileexists("atmt.filename") Then
'filename = "C:\Email Attachments" & _
'Format(item.CreationTime, "yyyymmdd_hhnnss_") & atmt.filename
'End If
i = i + 1
Next atmt

'Moves Email into reviewed folder.
Set DestFolder = Inbox.Folders("_Reviewed")
Item.Move DestFolder

Next Item

End If

If i > 0 Then
MsgBox "Found " & i & " attached files." _
& vbCrLf & "Saved to designated folder" _
, vbInformation, "finished!"
Else
MsgBox "There was no files attached to these emails.", vbInformation, _
"finished!"
End If

extraction_exit:
Set atmt = Nothing
Set Item = Nothing
Set Ns = Nothing
Exit Sub

extraction_err:
MsgBox "An unexpected error has occured." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: extraction" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume extraction_exit

End Sub

[Chris_AAA]

oh wow.... some really useful advise there. I will have a play. Thank you so much for your help and response.

Have a lovely day