VBA Code to save an attachment (excel file) from an Outlook email that was inside another email as an attachment

Question

I have code that saves attachments in message in a specific Outlook folder.

My script will work if the email has an attachment, but will not work if the email was s

Answer 1

The code below uses this approach to work on the email as an attachment

1. Tests whether the attachment is an email message or not (if the filename ends in msg)
2. If the attachment is a message, it is saved as "C:\temp\KillMe.msg".
3. CreateItemFromTemplate is used to access the saved file as a new message (msg2)
4. The code then processes this temporary message to strip the attachmnets to fsSaveFolder
5. If the attachment is not a message then it is extracted as per your current code

Note that as I didnt have your olFolder structure, Windoes version, Outlook variable etc I have had to add in my own file paths and Outlook folders to test. You will need to change these

   Sub SaveOlAttachments()

    Dim olFolder As Outlook.MAPIFolder
    Dim msg As Outlook.MailItem
    Dim msg2 As Outlook.MailItem
    Dim att As Outlook.Attachment
    Dim strFilePath As String
    Dim strTmpMsg As String
    Dim fsSaveFolder As String

    fsSaveFolder = "C:\test\"

    '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 olFolder = olFolder.Folders("Temp")
    If olFolder Is Nothing Then Exit Sub

    For Each msg In olFolder.Items
        If msg.Attachments.Count > 0 Then
        While msg.Attachments.Count > 0
        bflag = False
            If Right$(msg.Attachments(1).FileName, 3) = "msg" Then
                bflag = True
                msg.Attachments(1).SaveAsFile strFilePath & strTmpMsg
                Set msg2 = Application.CreateItemFromTemplate(strFilePath & strTmpMsg)
            End If
            If bflag Then
                sSavePathFS = fsSaveFolder & msg2.Attachments(1).FileName
                msg2.Attachments(1).SaveAsFile sSavePathFS
                msg2.Delete
            Else
                sSavePathFS = fsSaveFolder & msg.Attachments(1).FileName
                msg.Attachments(1).SaveAsFile sSavePathFS
            End If
            msg.Attachments(1).Delete
            Wend
             msg.Delete
        End If
    Next
    End Sub