Excel -VB - Opening Microsoft Outlook attachments from saved .msg files (new problem)

[rchawda]

Hi DKenny,

I am referring to this after a long-long time.
I tried this code of yours - it worked great for picking up one .msg file from a folder.
But the user has to run the macro multiple times to extract attachments from all the .msg files in a given folder.
Can you help pls with a modified version of this code, to open all the .msg files from a given folder and extract all the attachments (from each .msg) into another specified folder?
This was perhaps the original requirement of Shootme too!
May be Shootme could manage with the piece of code you shared.

Would be greatfull if you can enhance this code of yours to accomplish the task of extracting the attachments from each and every .msg files stored in a folder in one go (macro to be executed only once).

Regards

Rajesh

Opening MailItems that have been saved as .msg files is really difficult. One easy work around it to create a copy of the file using the CreateItemFromTemplate method of the Outlook application. This makes a copy of the msg file that you can work with in subsequent code.
Here's a procedure that should give you what you need. I've used the FileDialog object rather than the GetOpenFilename method, as it has move flexibility.
Note: I wrote this in Excel, and you will need to add a reference to the Outlook library.

Option Explicit
 
Sub ShootMe()
Dim sMessagePath As String
Dim sSavePath As String
Dim OLApp As Outlook.Application
Dim oMessage As Outlook.MailItem
Dim oMsgAttach As Outlook.Attachment
 
    '----------------------------------------------------------
    'First get the path for the .msg file
    '----------------------------------------------------------
    
    With Application.FileDialog(msoFileDialogFilePicker)
        
        'only allow a single file to be selected
        .AllowMultiSelect = False
        
        .Title = "Select Message File"
        
        'Filter the file list to only
        'include .msg files
        With .Filters
            .Clear
            .Add "Message Files", "*.msg"
        End With
        
        'If the user selects a file
        'record the path,
        'otherwise quit execution
        If .Show = -1 Then
            sMessagePath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    '----------------------------------------------------------
    'Next, get the save path
    '----------------------------------------------------------
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = "Select Save Folder"
        
        If .Show = -1 Then
            sSavePath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    '----------------------------------------------------------
    'Now we need to open the message and export the attachments
    '----------------------------------------------------------
    
    'Create Outlook objects
    Set OLApp = New Outlook.Application
    Set oMessage = OLApp.CreateItemFromTemplate(sMessagePath)
    
    'Loop through each attachment...
    For Each oMsgAttach In oMessage.Attachments
    
        With oMsgAttach
            '... saving it to the destination folder
            .SaveAsFile Path:=sSavePath & "\" & .DisplayName
        End With
    Next oMsgAttach
    
    'Clear object variables
    Set OLApp = Nothing
    Set oMessage = Nothing
    Set oMsgAttach = Nothing
End Sub