Extract attachments from saved .msg files using VBA

Question

I am trying to extract attached Excel spreadsheets from saved Outlook messages. The messages have been saved into a shared folder as .msg files.

I am struggling to get VBA to recognise the messages as files.

I am trying to get the message details in the code below as a proof of concept.

Once I have this working I can work on looping through the files and dealing with the attachments.

I have found code on this site for extracting attachments from emails still in Outlook but I do not have access to the Outlook folders and the original messages have been deleted.

Sub ExtractExcel()
Dim aExcel As Outlook.Attachment
Dim stFilePath As String
Dim stFileName As String
Dim stAttName As String
Dim stSaveFolder As String
Dim oEmail As Outlook.MailItem

'~~> Outlook Variables for email
Dim eSender As String, dtRecvd As String, dtSent As String
Dim sSubj As String, sMsg As String

stFilePath = "Y:\Purchasing\The Team\User Name\Supply Chain Admin - Outlook\New-Revised Orders\FW  Mail Order Daffodil.msg"
stSaveFolder = "C:\Projects\SOTD\PO_Excel"

Debug.Print stFilePath
Debug.Print stSaveFolder

oEmail = stFilePath

With oEmail 
    eSender = oEmail.SenderEmailAddress
    dtRecvd = oEmail.ReceivedTime
    dtSent = oEmail.CreationTime
    sSubj = oEmail.Subject
    sMsg = oEmail.Body

    Debug.Print eSender
    Debug.Print dtRecvd
    Debug.Print dtSent
    Debug.Print sSubj
    Debug.Print sMsg
End With

End Sub

I'm using Excel VBA as I am familiar with it but am happy to have any alternative strategies suggested.

Answer 1

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

• open msg files from C:\temp\
• strip all attachments to C:\temp1\

code

Sub SaveOlAttachments()

Dim msg As Outlook.MailItem
Dim att As Outlook.Attachment
Dim strFilePath As String
Dim strAttPath As String

    'path for creating msgs
strFilePath = "C:\temp\"
    'path for saving attachments
strAttPath = "C:\temp1\"

strFile = Dir(strFilePath & "*.msg")
Do While Len(strFile) > 0
    Set msg = Application.CreateItemFromTemplate(strFilePath & strFile)
    If msg.Attachments.Count > 0 Then
         For Each att In msg.Attachments
             att.SaveAsFile strAttPath & att.FileName
         Next
    End If
    strFile = Dir
Loop

End Sub