Saving attached emails to an Outlook folder

[ulihuber]

Hi,

I have emails sent to me and containing several other emails as attachments. I need those emails in their original format, therefore I cannot have them just forwarded.
Normally I use drag-and-drop to move those attached emails into an Outlook folder, but this is annoying.

So I wanted to write a small script that does the work for me. The idea is just to just mark the incoming email and start the script. It loops through the attachments and moves them to a folder. While this looked easy on a first view, I struggle in emulating the cut-and-paste operation.
If I try to use the .move method on the .attachment within the inner loop, I always get Error 438 "Object Doesn't Support This Property or Method". It just looks like the attachment is not recognized as a mail item. But it can be saved to a .msg file and then imported.
So my work around is as as follows:

Sub GetAttachedEmails()
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim objMail, objItem , objMsg, As Object
 
    Set objOutlook = CreateObject("Outlook.Application")
    Set objnSpace = objOutlook.GetNamespace("MAPI")
    Set objFolder = objnSpace.folders("Inbox")
   
    For Each objMail In Application.ActiveExplorer.Selection
        For Each objItem In objMail.Attachments
            objItem.SaveAsFile "dummy.msg"
            Set objMsg = Session.OpenSharedItem("dummy.msg")
            objMsg.Move objFolder
        Next objItem
    Next objMail
   
End Sub

This works, but I’d rather get rid of the construction with the dummy file. Any idea how to accomplish that?

Thanks
Uli

[SamT]

Moderator Bump

[gmayor]

I don't believe it is possible, however I don't see why you are creating a new Outlook application when you could use the one you are working in. I would probably do it as follows

Sub GetAttachedEmails()
Dim objnSpace As NameSpace, objFolder As Folder
Dim objMail As MailItem, objItem As Attachment, objMsg As MailItem

    Set objnSpace = GetNamespace("MAPI")
    Set objFolder = objnSpace.GetDefaultFolder(olFolderInbox)
    On Error Resume Next
    For Each objMail In Application.ActiveExplorer.Selection
        For Each objItem In objMail.Attachments
            objItem.SaveAsFile Environ("TEMP") & "\dummy.msg"
            Set objMsg = Session.OpenSharedItem(Environ("TEMP") & "\dummy.msg")
            objMsg.Move objFolder
            objMsg.Close olDiscard
        Next objItem
    Next objMail
    Kill Environ("TEMP") & "\dummy.msg"
End Sub