VBA to individually forward more than 1 attached emails (message attachments)

Question

Found plenty of posts for forwarding a single email, but this is another issue. I have hundreds of emails, each containing between 3 and 8 attached email messages (not regular attachments like PDFs, etc.). How can I get a macro to forward each of those attached messages in its own individual email? Been trying code like the snippet below but of course it stops at the asterisks. Grateful for any clues.

Sub ForwardEachAttachmentIndividually()
    Dim OA As Application, OI As Outlook.Inspector, i As Long
    Dim msgx As MailItem, msgfw As MailItem
    Set OA = CreateObject("Outlook.Application")
    Set OI = Application.ActiveInspector
    Set msgx = OI.CurrentItem
    For i = 1 To msgx.Attachments.Count
        If Right(msgx.Attachments(i).DisplayName, 4) = ".msg" Then
            Set msgfw = CreateItem(olMailItem)
            msgfw.Display
            msgfw.Attachments.Add msgx.Attachments(i)  '***nggh
            msgfw.Attachment(i).Forward
            msgfw.Recipients.Add "zelda@foobar.com"
            msgfw.Send
        End If
    Next
End Sub

Answer 1

Below is brute force method using API posted here.

Sub test()
    Dim olApp As Outlook.Application: Set olApp = Outlook.Application
    Dim objNS As Outlook.NameSpace: Set objNS = olApp.GetNamespace("MAPI")
    Dim olFol As Outlook.MAPIFolder: Set olFol = objNS.GetDefaultFolder(olFolderInbox)
    Set olFol = olFol.Folders("Test Folder") 'change to suit

    Dim msg As Outlook.MailItem, att As Outlook.Attachment
    Set msg = olFol.Items(olFol.Items.Count) 'change to suit

    Dim strfile As String, fmsg As Outlook.MailItem
    For Each att In msg.Attachments
        If att.Type = 5 Then 'check if it is of olEmbeddedItem Type
            strfile = Environ("Temp") & "\" & att.FileName
            att.SaveAsFile strfile
            'Use the function to open the file
            ShellExecute 0, "open", strfile, vbNullString, vbNullString, 0
            'Wait until it is open
            Do While olApp.Inspectors.Count = 0: DoEvents
            Loop
            'Grab the inspector
            Set fmsg = olApp.Inspectors.Item(1).CurrentItem
            'Forward message
            With fmsg.Forward
                .To = "zelda@foobar.com"
                .Send
            End With
            'Close and discard inspector
            fmsg.Close 1: Set fmsg = Nothing '1 is for olDiscard
            'Delete the file
            Kill strfile
        End If
    Next
End Sub

Here is the Function just in case the link is broken

Private Declare Function ShellExecute Lib "shell32.dll" Alias _
    "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
    ByVal lpFile As String, ByVal lpParameters As String, _
    ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

This is tried and tested. So first, I tried the latest message in Test Folder in my Inbox.
Then we check if the msg have attachments of olEmbeddedItem type (attached mailitem).
Take note that you still need to check if msg is type MailItem (I skipped it in my testing).
The two answers above is correct that you need to save the file.
Once saved, open it using the API and what you need is just grab the Inspector.
You need to add another loop if you are to repeat this with a lot of emails. HTH.

Answer 2

Attachments.Add Method

"The source of the attachment. This can be a file (represented by the full file system path with a file name) or an Outlook item that constitutes the attachment."

The .msg files are attachments not Outlook items so save the .msg files in a temporary folder.

Edit2: Based on comment from Eugene. The answer stops at the line above. The example code shows how to save an msg attachment and gives an idea about saving only one file. It is not the actual solution. End of Edit2.

There is an interesting method here where the msg files are all saved as "KillMe.msg" so if necessary, there is only one file to programatically kill or manually delete.

Edit1: For illustration purposes only. You will likely want to use the actual names. Keep in mind you will want to remove illegal characters in the file names. End of Edit1

Sub SaveOlAttachments()

Dim olFolder As MAPIFolder
Dim olFolder2 As MAPIFolder
Dim msg As MailItem
Dim msg2 As MailItem
Dim strFilePath As String
Dim strTmpMsg As String

'path for creating attachment msg file for stripping
strFilePath = "C:\temp\"
strTmpMsg = "KillMe.msg"

'My testing done in Outlok using a "temp" folder underneath Inbox
Set olFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set olFolder2 = olFolder.Folders("Forwarded")
Set olFolder = olFolder.Folders("Received")

For Each msg In olFolder.Items
    If msg.Attachments.Count > 0 Then
        If Right$(msg.Attachments(1).FileName, 3) = "msg" Then
            msg.Attachments(1).SaveAsFile strFilePath & strTmpMsg
            Set msg2 = Application.CreateItemFromTemplate(strFilePath & strTmpMsg)
        End If
        msg.Delete
        msg2.Move olFolder2
    End If
Next
End Sub

Answer 3

You need to save the attachments first.

Sub ForwardEachAttachmentIndividually()
    Dim OA As Application, OI As Outlook.Inspector, i As Long
    Dim msgx As MailItem, msgfw As MailItem
    Set OA = CreateObject("Outlook.Application")
    Set OI = Application.ActiveInspector
    Set msgx = OI.CurrentItem
    Dim strPath As String
    For i = 1 To msgx.Attachments.Count
        If Right(msgx.Attachments(i).DisplayName, 4) = ".msg" Then
            Set msgfw = CreateItem(olMailItem)
            msgfw.Display
            strPath = "C:\Users\me\Documents\tempAtt" & msgx.Attachments(i).FileName
            msgx.Attachments(i).SaveAsFile strPath
            msgfw.Attachments.Add strPath
            'msgfw.Attachments.Add msgx.Attachments(i)  '***nggh
            msgfw.Attachment(i).Forward
            msgfw.Recipients.Add "zelda@foobar.com"
            msgfw.Send
        End If
    Next
End Sub