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