Automatically Unpack Attached Messages

Question

I have a secondary exchange account where a server rule is active that forwards every mail it receives to my primary account (on another server). To avoid pointless forwarding headers and to preserve the From and To fields, I forward mails as an attachment and

I have three issues with this code and am a bit stuck, so I'm posting it here to hopefully get some input:

• I'd like to run attachment validation so only actual message types are unpacked to the Inbox. I've found the .Type property but this only gives me a number and I can't find the corresponding reference. If any non-message attachments (or no attachments) are found, the forwarding message should be saved or not deleted.
• Items are created in the Inbox as drafts instead of received mail items. I can't find any way to change the document type.
• It seems like my code randomly creates empty messages in my Outbox. Perhaps this is due to opening the message from disk and not doing anything with it apart from moving it, but I can't really be sure right now. If an unpacked message has attachments, an empty draft with those attachments can be found in the Outbox.

Below I've posted the entire code, created largely thanks to information from an answer to a related question.

Public Sub unpackAttachedMessage(itm As Outlook.MailItem)


    Dim olApp As New Outlook.Application
    Dim olNameSpace As Outlook.NameSpace
    Dim olTargetFolder As Outlook.Folder
    Dim objAtt As Outlook.Attachment

    ' Program Configuration Variables and Constants
    Const saveFolder As String = "C:\Temp\Outlook"
    Const messageCategory As String = "CategoryName"

    ' Runtime Variables
    Dim i As Integer
    Dim attachmentCount As Integer
    i = 1

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    ' Folder creation does not seem to work.
    If Not fso.FolderExists(saveFolder) Then
        fso.CreateFolder (saveFolder)
    End If


    ' For each attachment in the message.
    For Each objAtt In itm.Attachments
        ' Save it to disk as a message.
        objAtt.SaveAsFile saveFolder & "\" & i & ".msg"

        ' Retrieve a message from disk.
        Dim message As Outlook.MailItem
        Set message = Application.CreateItemFromTemplate(saveFolder & "\" & i & ".msg")

        ' Modify the Message.
        ' Note that this and potentially other message options need
        '   to be set BEFORE you move the item to its destination folder.
        ' Set the Category.
        message.Categories = message.Categories & "," & messageCategory
        ' Mark as unread.
        message.UnRead = True

        ' MsgBox "Class: " & itm.MessageClass & " --- Attached Item Class: " & message.MessageClass
        ' Doesn't work
        'message.MessageClass = olPostItem

        ' Save changes to the message.
        message.Save

        ' Move the item to Inbox.
        Set olNameSpace = olApp.GetNamespace("MAPI")
        Set olTargetFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
        message.Move olTargetFolder

        ' objAtt.DisplayName
        Set objAtt = Nothing
        i = i + 1
    Next
    attachmentCount = i

End Sub

Answer 1

You can try to use Namespace.OpenSharedItem, but as far as I know it will have the same problem.

If using Redemption is an option, you can create a server side delegate rule that will not mangle the original message (http://www.dimastr.com/redemption/rdoruleactions.htm, you will need Redirect action).

To extract an embedded message attachment, you can use RDOAttachment.EmbeddedMsg property (returns RDOMail object). You should be able to copy that message to any folder. Something along the lines (off the top of my head):

set Session = CreateObject("Redemption.RDOSession")
Session.MAPIOBJECT = Application.Session.MAPIOBJECT
set rdoMsg = Session.GetRDOObjectFromOutlookObject(itm)
set Inbox = Session.GetDefaultFolder(olFolderInbox)
For Each objAtt In rdoMsg.Attachments
  if objAtt.Type = olEmbeddedItem Then 
    set newmsg = Inbox.Items.Add("IPM.Note")
    newmsg.Sent = true 'must be set before Save is called for the first time
    objAtt.EmbeddedMsg.CopyTo(newmsg)
    newmsg.Save
  End If
next

Answer 2

Thanks to the input of the people who answered and commented here, I now have a working VBA function that unpacks all message attachments for a MailItem to the Inbox. It also adds a category and marks them as unread. This works by using the OpenSharedItem method in the MAPI Namespace in Outlook.Application. The full VBA code can be found below. I've seen this brought up several times in online fora so I hope this will be useful to others as well.

' This program moves all message attachments for the handled MailItem to the inbox, adds a category and marks them as unread.
Public Sub unpackAttachedMessage(itm As Outlook.MailItem)

    Dim olApp As New Outlook.Application
    Dim olNameSpace As Outlook.NameSpace
    Dim objAtt As Outlook.Attachment
    Dim message As Outlook.MailItem
    Dim myCopiedItem As Outlook.MailItem

    ' Program Configuration Variables and Constants
    Const saveFolder As String = "C:\Temp\Outlook"
    Const messageCategory As String = "Category"

    Set olNameSpace = olApp.GetNamespace("MAPI")

    ' Create the temporary save folder if it does not exist.
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(saveFolder) Then
        fso.CreateFolder (saveFolder)
    End If

    ' Runtime Variables
    Dim i As Integer
    i = 1

    ' For each attachment in the MailItem.
    For Each objAtt In itm.Attachments

        ' If it's a message type,
        If objAtt.Type = olEmbeddeditem And Right(objAtt.FileName, 4) = ".msg" Then

            ' Save it to disk,
            objAtt.SaveAsFile saveFolder & "\" & i & ".msg"

            ' Read it from disk as a Shared Item,
            Set message = olNameSpace.OpenSharedItem(saveFolder & "\" & i & ".msg")

            ' Set the Category,
            message.Categories = message.Categories & "," & messageCategory
            ' Mark it as Unread,
            message.UnRead = True

            ' and Move it to the Inbox by creating a copy.
            Set myCopiedItem = message.Copy
            message.Delete

            ' Clear the references
            Set message = Nothing
            Set myCopiedItem = Nothing
            Set objAtt = Nothing

            ' and remove the files from disk.
            Kill (saveFolder & "\" & i & ".msg")
        End If
        i = i + 1
    Next

End Sub

Note that this code only unpacks message attachments and ignores everything else. I personally run it in a rule that runs for specific forward-only accounts and perma-deletes every handled message, but take care that you don't throw away any legitimate mails in this case. This code could probably be improved by specifying a folder other than the Inbox to move it to, if you so desire.

Answer 3

in this solution you loose some header-Information, but it does not need redemption.

Sub test()
Dim path As String
Dim olApp As Outlook.Application
Dim olitem As Outlook.MailItem
Dim olfolder As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olitem = Application.ActiveInspector.CurrentItem
Set olfolder = GetFolder(olitem.Parent.folderPath)
path = "c:\test\"

For Each objAtt In olitem.Attachments
  If objAtt.Type = olEmbeddeditem And Right(objAtt.FileName, 3) = "msg" Then
     objAtt.SaveAsFile path & "\" & objAtt.FileName
     Set objFile = olApp.CopyFile(path & "\" & objAtt.FileName, olfolder)
    Kill path & "\" & objAtt.FileName
  End If
Next
End Sub

Public Function GetFolder(strFolderPath As String) As MAPIFolder
  ' strFolderPath needs to be something like
  '   "Public Folders\All Public Folders\Company\Sales" or
  '   "Personal Folders\Inbox\My Folder"
  Dim objApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim colFolders As Outlook.Folders
  Dim objFolder As Outlook.MAPIFolder
  Dim arrFolders() As String
  Dim i As Long
 ' On Error Resume Next

  strFolderPath = Replace(strFolderPath, "\\", "")
  strFolderPath = Replace(strFolderPath, "/", "\")
  arrFolders() = Split(strFolderPath, "\")
  Set objApp = Application
  Set objNS = objApp.GetNamespace("MAPI")
  Set objFolder = objNS.Folders.Item(arrFolders(0))
  If Not objFolder Is Nothing Then
    For i = 1 To UBound(arrFolders)
      Set colFolders = objFolder.Folders
      Set objFolder = Nothing
      Set objFolder = colFolders.Item(arrFolders(i))
      If objFolder Is Nothing Then
        Exit For
      End If
    Next
  End If

  Set GetFolder = objFolder
  Set colFolders = Nothing
  Set objNS = Nothing
  Set objApp = Nothing
End Function