VBA to extract all attachments from .msg file?

[Alphix]

I need help on how to extract attachments in from several .msg files in a designated folder.
I need a VBA code tode to do this.

Please help.

 

[John_w]

Try this macro. You need to edit the code where indicated.

Public Sub Extract_Attachments_From_Outlook_Msg_Files()

    Dim outApp As Object
    Dim outEmail As Object
    Dim outAttachment As Object
    Dim msgFiles As String, sourceFolder As String, saveInFolder As String
    Dim fileName As String
    
    msgFiles = "C:\path\to\folder\*.msg"       'CHANGE - folder location and filespec of .msg files
    saveInFolder = "C:\path\to\folder"         'CHANGE - folder where extracted attachments are saved
    
    If Right(saveInFolder, 1) <> "\" Then saveInFolder = saveInFolder & "\"
    sourceFolder = Left(msgFiles, InStrRev(msgFiles, "\"))
    
    On Error Resume Next
    Set outApp = GetObject(, "Outlook.Application")
    If outApp Is Nothing Then
        MsgBox "Outlook is not open"
        Exit Sub
    End If
    On Error GoTo 0
    
    fileName = Dir(msgFiles)
    While fileName <> vbNullString
        
        'Open .msg file in Outlook 2003
        'Set outEmail = outApp.CreateItemFromTemplate(sourceFolder & fileName)
        
        'Open .msg file in Outlook 2007+
        Set outEmail = outApp.Session.OpenSharedItem(sourceFolder & fileName)
        
        For Each outAttachment In outEmail.Attachments
            outAttachment.SaveAsFile saveInFolder & outAttachment.fileName
        Next
    
        fileName = Dir
        
    Wend
    
End Sub

 

[Alphix]

This works perfectly!!!!
Thank you very much,
May you have a blessed day.

 

[mirpurik18]

Dear Sir,

My msg files are in outlook mail\inbox\msg folder and I want to extract on desktop. According to your instructions but I am getting error "Expected: If or Else or Elself or End or Endif or Const". I hereby paste my macro below:
Public Sub Extract_Attachments_From_Outlook_Msg_Files()
Dim outApp As Object
Dim outEmail As Object
Dim outAttachment As Object
Dim msgFiles As String, sourceFolder As String, saveInFolder As String
Dim fileName As String

msgFiles = "kiran.mirpuri@shankarpack.com\Inbox\MSG\*.msg"
saveInFolder = "D:\Tally.ERP9\Desktop\export"
If Right(saveInFolder, 1) <> "" Then saveInFolder = saveInFolder & ""
sourceFolder = Left(msgFiles, InStrRev(msgFiles, ""))

On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If outApp Is Nothing Then
MsgBox "Outlook is not open"
Exit Sub
End If
On Error GoTo 0

fileName = Dir(msgFiles)
While fileName <> vbNullString

'Open .msg file in Outlook 2003
'Set outEmail = abc@xyz.com\Inbox\MSG

'Open .msg file in Outlook 2007+
Set outEmail =abc@xyz.com\Inbox\MSG

For Each outAttachment In outEmail.Attachments
outAttachment.SaveAsFile saveInFolder & outAttachment.fileName
Next

fileName = Dir

Wend

End Sub

PLEASE HELP ME OUT

 

[mirpurik18]

Dear Sir,

Dear Sir,

Still I getting error.

Pls help me this is very imp for me.

 

[John_w]

My msg files are in outlook mail\inbox\msg folder and I want to extract on desktop.

The code is for .msg (Outlook Message Format) files in a folder on your local disk, NOT for emails in an Outlook folder.

To extract all the attachments from an Outlook email try adapting the code at https://www.mrexcel.com/forum/excel...ing-subject-line-post3443884.html#post3443884 for your requirements or try https://www.rondebruin.nl/win/s1/outlook/saveatt.htm

 

[DaltonB]

Try this macro. You need to edit the code where indicated.

Public Sub Extract_Attachments_From_Outlook_Msg_Files()

    Dim outApp As Object
    Dim outEmail As Object
    Dim outAttachment As Object
    Dim msgFiles As String, sourceFolder As String, saveInFolder As String
    Dim fileName As String
   
    msgFiles = "C:\path\to\folder\*.msg"       'CHANGE - folder location and filespec of .msg files
    saveInFolder = "C:\path\to\folder"         'CHANGE - folder where extracted attachments are saved
   
    If Right(saveInFolder, 1) <> "\" Then saveInFolder = saveInFolder & "\"
    sourceFolder = Left(msgFiles, InStrRev(msgFiles, "\"))
   
    On Error Resume Next
    Set outApp = GetObject(, "Outlook.Application")
    If outApp Is Nothing Then
        MsgBox "Outlook is not open"
        Exit Sub
    End If
    On Error GoTo 0
   
    fileName = Dir(msgFiles)
    While fileName <> vbNullString
       
        'Open .msg file in Outlook 2003
        'Set outEmail = outApp.CreateItemFromTemplate(sourceFolder & fileName)
       
        'Open .msg file in Outlook 2007+
        Set outEmail = outApp.Session.OpenSharedItem(sourceFolder & fileName)
       
        For Each outAttachment In outEmail.Attachments
            outAttachment.SaveAsFile saveInFolder & outAttachment.fileName
        Next
   
        fileName = Dir
       
    Wend
   
End Sub

I created an account just to say "Thank you" for this. It saved me so much time!