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

  • 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?



    Thursday, July 6, 2017 3:26 AM

All replies

  • 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
    End If
    End Sub



    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 MSDNFSF@microsoft.com.

    • Proposed as answer by Chenchen Li Wednesday, July 12, 2017 7:32 AM
    Friday, July 7, 2017 6:12 AM