Save Outlook attachments (that are emails themselves) to another folder in Outlook, can this be done?

Question

I have seen a lot of information on how to save Outlook attachments to folders on desktop or network.  I need to extract the attachments from email in an inbox  and move them to another subfolder.  These attachments are emails, doing this by hand every day gets very tiring and I would like a script or macro I can run that will pull all the attachments in the subfolder.  this folder usually has about 500 emails that have at least one email attached to each one.  I need to scrape all of the attached emails into one folder together.

Any Ideas?

Thanks,

LJB

Answer 1

Hello,

How do you move these attached mailitem to one folder manually?

Do you open the attached mailitem and then go to File -> Info -> Move to Folder -> Copy to Folder ?

You could firstly search all items with attachments and then check if its attachment is a mail item, then save it into local and open it in Outlook, then you could copy the attached mailitem in a certain folder.

The code below could search inbox and save all attached msg file into subfolder of inbox.

Sub Demo()
Dim qry As String
Dim myInbox As Items
Dim myItems As Items
Dim myItem As Object
Dim myMailitem As MailItem
Dim att As Attachment
Dim path As String
Dim eml As MailItem
Dim myCopiedItem As MailItem
qry = "@SQL=" & Chr(34) & "urn:schemas:httpmail:hasattachment" & Chr(34) & "=1"
Set myInbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items
Set myItems = myInbox.Restrict(qry)
For Each myItem In myItems
If TypeOf myItem Is Outlook.MailItem Then
    Set myMailitem = myItem
    For Each att In myMailitem.Attachments
        If att.Type = olEmbeddeditem Then
            path = "D:\test\" & att.FileName
            att.SaveAsFile (path)
            Set eml = Application.GetNamespace("MAPI").OpenSharedItem(path)
            Set myCopiedItem = eml.Copy
            myCopiedItem.Move Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("subfolder")
            Kill path
        End If
    Next
End If
Next
End Sub

Regards,

Celeste

---

MSDN Community Support
Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact [e-mail].