Extract Attachments from Saved Outlook Emails using Excel VBA

This tutorial will cover how to extract attachments from saved Outlook emails messages using Excel VBA. A saved Outlook message is where you copy an email message from Outlook and save it in your computer folder as a .msg message. If you have the right rules setup in Outlook, you can copy and paste multiple Outlook messages quite easily onto your computer drive.

Extracting attachments from saved Outlook messages using Excel VBA is a safer way to download attachments. As opposed to directly connecting to the Outlook mailbox and extracting messages from there. There is no risk here, of accidently deleting off the the emails. If something goes wrong, the saved messages will be unaffected. This gives us the perfect platform to experiment. I have built stable and complex code to extract 100s of messages with all sorts of attachments, using this technique.

The video contains 3 demos; built on top of each other. Full code for each demo is given below. For this code to work, you’ll first need to connect to the Outlook library. Go to Tools -> References and select the Outlook Object library.

If you like this video and blog, please check out my other Outlook and Excel VBA related content on how to send Outlook Emails: Tutorial 1, Tutorial 2, Tutorial 3.

Demo 1- Extract Outlook Attachments with Excel VBA

This is the vanilla version where we see how to extract attachments as-is from multiple Outlook messages saved on our computer drive. We don’t yet amend the file name to account for duplicate file names (Demo 2) or include any error handling (Demo 3).

The following setup is required for this code to work. The macro file with this code needs to be saved on the computer. There will need to be two folders named “In” and “Out” created in the same location as the macro file. Your saved Outlook messages will need to be saved in the “In” folder, and the attachments will be extracted in the “Out” folder.

Option Explicit

Const csOutlookIn As String = "In"
Const csOutlookOut As String = "Out"

Sub Extract_Emails_Demo1()
Application.ScreenUpdating = False

Dim sCurrentFolder As String
sCurrentFolder = ActiveWorkbook.Path & "\"

Dim FSO As Scripting.FileSystemObject
Set FSO = New Scripting.FileSystemObject

Dim fldrOutlookIn As Scripting.Folder
Set fldrOutlookIn = FSO.GetFolder(sCurrentFolder & csOutlookIn)

Dim oApp As Outlook.Application
Set oApp = New Outlook.Application

Dim oMail As Outlook.MailItem
Dim oAttach As Outlook.Attachment

Dim fileItem As Scripting.File
Dim sAttachName As String
For Each fileItem In fldrOutlookIn.Files
    Set oMail = oApp.CreateItemFromTemplate(fileItem.Path)
    For Each oAttach In oMail.Attachments
        sAttachName = oAttach.Filename
        sAttachName = sCurrentFolder & csOutlookOut & "\" & sAttachName
        oAttach.SaveAsFile sAttachName
    Next oAttach
    Set oMail = Nothing
Next fileItem

MsgBox "Done!"
Application.ScreenUpdating = True
End Sub

Demo 2 – Avoid Duplicates While Extracting Attachments

The code in Demo 1 will work in most cases. However, we will run into an issue if the two or more attachments have the same file name. To avoid this, we can amend the code slightly by adding a unique prefix at the start of the file name as we save the attachment.

The prefix that I use is “file” and is declared as a Constant right at the start. This along with the counter variable will assign the prefixes “file1”, “file2”, “file3” etc. to the files as they get extracted. You can choose to rename this prefix to anything else, by changing the constant.

Option Explicit

Const csOutlookIn As String = "In"
Const csOutlookOut As String = "Out"
Const csFilePrefix As String = "file"

Sub Extract_Emails_Demo2()
Application.ScreenUpdating = False

Dim sCurrentFolder As String
sCurrentFolder = ActiveWorkbook.Path & "\"

Dim FSO As Scripting.FileSystemObject
Set FSO = New Scripting.FileSystemObject

Dim fldrOutlookIn As Scripting.Folder
Set fldrOutlookIn = FSO.GetFolder(sCurrentFolder & csOutlookIn)

Dim oApp As Outlook.Application
Set oApp = New Outlook.Application

Dim oMail As Outlook.MailItem
Dim oAttach As Outlook.Attachment

Dim fileItem As Scripting.File
Dim sAttachName As String
Dim lcounter As Long
lcounter = 0
Dim scounter As String
For Each fileItem In fldrOutlookIn.Files
    Set oMail = oApp.CreateItemFromTemplate(fileItem.Path)
    For Each oAttach In oMail.Attachments
        lcounter = lcounter + 1
        scounter = Format(lcounter, "000")
        sAttachName = oAttach.Filename
        sAttachName = sCurrentFolder & csOutlookOut & "\" & csFilePrefix & scounter & "_" & sAttachName
        oAttach.SaveAsFile sAttachName
    Next oAttach
    Set oMail = Nothing
Next fileItem

MsgBox "Done!"
Application.ScreenUpdating = True
End Sub

Demo 3 – Error Handling

We can go a step further and add some error handling to account for user related issues such as not removing the extracted attachments from the “Out” folder, before running the macro for the next run. We will also, create a detailed log of what got extracted and what was skipped over.

Option Explicit

Const csOutlookIn As String = "In"
Const csOutlookOut As String = "Out"
Const csFilePrefix As String = "file"

Sub Extract_Emails_Demo3()
Application.ScreenUpdating = False

Dim sCurrentFolder As String
sCurrentFolder = ActiveWorkbook.Path & "\"

Dim FSO As Scripting.FileSystemObject
Set FSO = New Scripting.FileSystemObject

If Not FSO.FolderExists(sCurrentFolder & csOutlookIn) Then
    MsgBox "Folder """ & csOutlookIn & """ doesn't exist in Current Directory." & vbNewLine & _
            "For this macro to work, please: " & vbNewLine & _
            "1. Create a folder called """ & csOutlookIn & """ in this directory " & vbNewLine & _
            "2. Place your outlook messages there." & vbNewLine & _
            "Thanks!", vbCritical, "Error Occured"
    Application.ScreenUpdating = True
    Exit Sub
End If

If Not FSO.FolderExists(sCurrentFolder & csOutlookOut) Then
    FSO.CreateFolder (sCurrentFolder & csOutlookOut)
End If

wsMain.Range("G:I").ClearContents
wsMain.Range("G1").Value = "Outlook Message Name"
wsMain.Range("H1").Value = "Outlook Attachment Name"
wsMain.Range("I1").Value = "Outlook Status"

Dim fldrOutlookIn As Scripting.Folder, fldrOutlookOut As Scripting.Folder
Set fldrOutlookIn = FSO.GetFolder(sCurrentFolder & csOutlookIn)
Set fldrOutlookOut = FSO.GetFolder(sCurrentFolder & csOutlookOut)


If fldrOutlookIn.Files.Count = 0 Then
    MsgBox "There can be no files in the """ & csOutlookOut & """ folder." & vbNewLine & _
            "Please empty the folder and re-run the macro. Thanks!", vbCritical, "Error Occured"
    Application.ScreenUpdating = True
    Exit Sub
End If

If fldrOutlookOut.Files.Count <> 0 Then
    MsgBox "There can be no files in the """ & csOutlookOut & """ folder." & vbNewLine & _
            "Please empty the folder and re-run the macro. Thanks!", vbCritical, "Error Occured"
    Application.ScreenUpdating = True
    Exit Sub
End If

Dim oApp As Outlook.Application
Set oApp = New Outlook.Application

Dim oMail As Outlook.MailItem
Dim oAttach As Outlook.Attachment

Dim fileItem As Scripting.File
Dim sAttachName As String
Dim lrow As Long
Dim lcounter As Long
lcounter = 0
Dim scounter As String
For Each fileItem In fldrOutlookIn.Files
    If Right(fileItem.Name, 3) <> "msg" Then
        GoTo LineNotOutlookMsg
    End If
    Set oMail = oApp.CreateItemFromTemplate(fileItem.Path)
    For Each oAttach In oMail.Attachments
        lcounter = lcounter + 1
        scounter = Format(lcounter, "000")
        sAttachName = oAttach.Filename
        sAttachName = sCurrentFolder & csOutlookOut & "\" & csFilePrefix & scounter & "_" & sAttachName
        oAttach.SaveAsFile sAttachName
        lrow = wsMain.Range("g1").CurrentRegion.Rows.Count
        wsMain.Range("G" & lrow).Offset(1).Value = fileItem.Name
        wsMain.Range("H" & lrow).Offset(1).Value = oAttach.Filename
        wsMain.Range("I" & lrow).Offset(1).Value = "Completed"
    Next oAttach
    If oMail.Attachments.Count = 0 Then
        lrow = wsMain.Range("g1").CurrentRegion.Rows.Count
        wsMain.Range("G" & lrow).Offset(1).Value = fileItem.Name
        wsMain.Range("H" & lrow).Offset(1).Value = ""
        wsMain.Range("I" & lrow).Offset(1).Value = "No attachments found"
    End If
    Set oMail = Nothing
    GoTo LineNextFile
LineNotOutlookMsg:
    lrow = wsMain.Range("g1").CurrentRegion.Rows.Count
    wsMain.Range("G" & lrow).Offset(1).Value = fileItem.Name
    wsMain.Range("H" & lrow).Offset(1).Value = ""
    wsMain.Range("I" & lrow).Offset(1).Value = "Not an outlook message"
LineNextFile:
Next fileItem

wsMain.Columns("G:I").AutoFit

MsgBox "Done!"
Application.ScreenUpdating = True
End Sub

Extract Attachments from Outlook Tasks

We will continue with the same code in Demo 2. An Outlook Task is an Object under the Outlook Application, just like an Outlook Email. We can use the exact same code with some tweaks.

All we have to do is replace Outlook.MailItem with Outlook.TaskItem.

I have made a few more modifications. Screenshots saved in a Task seem to be getting saved as a Picture Device Independent Bitmap), which error out when trying to extract them. To circumvent this, I have placed some error handling in the code. A Resume Next statement before we begin extracting (to skip over any errors) and a Go To 0 after we have done extracting (to give error control back to Excel).

One more modification is the ability to specify what file you want to extract. Once we grab the file name, we can check what the extension is. And we can put in an IF statement to only extract files, for the extensions that we need. Below example shows a case where we want to only extract pdf files and ignore the rest. If you want to extract two or more specific file types, add the condition to the IF statement separated by an OR.

        If Right(sAttachName, 4) = ".pdf" Then
            sAttachName = sCurrentFolder & csOutlookOut & "\" & sAttachName
            oAttach.SaveAsFile sAttachName
        End If

For now, though, I have commented out the IF statement for the extension. If you want to use it, just remove the apostrophe.

Option Explicit

Const csOutlookIn As String = "In"
Const csOutlookOut As String = "Out"
Const csFilePrefix As String = "file"

Sub Extract_Emails_Demo2()
Application.ScreenUpdating = False

Dim sCurrentFolder As String
sCurrentFolder = ActiveWorkbook.Path & "\"

Dim FSO As Scripting.FileSystemObject
Set FSO = New Scripting.FileSystemObject

Dim fldrOutlookIn As Scripting.Folder
Set fldrOutlookIn = FSO.GetFolder(sCurrentFolder & csOutlookIn)

Dim oApp As Outlook.Application
Set oApp = New Outlook.Application

Dim oTask As Outlook.TaskItem
Dim oAttach As Outlook.Attachment

Dim fileItem As Scripting.File
Dim sAttachName As String
Dim lcounter As Long
lcounter = 0
Dim scounter As String
For Each fileItem In fldrOutlookIn.Files
    Set oTask = oApp.CreateItemFromTemplate(fileItem.Path)
    On Error Resume Next
    For Each oAttach In oTask.Attachments
        sAttachName = oAttach.Filename
        'If Right(sAttachName, 4) = ".pdf" Then
            lcounter = lcounter + 1
            scounter = Format(lcounter, "000")
            sAttachName = sCurrentFolder & csOutlookOut & "\" & csFilePrefix & scounter & "_" & sAttachName
            oAttach.SaveAsFile sAttachName
        'End If
    Next oAttach
    On Error GoTo 0
    Set oTask = Nothing
Next fileItem

MsgBox "Done!"
Application.ScreenUpdating = True
End Sub

Extract Emails and Tasks

The following code will extract from files with extension .msg i.e. Emails and Tasks.

Option Explicit

Const csOutlookIn As String = "In"
Const csOutlookOut As String = "Out"
Const csFilePrefix As String = "file"

Sub Extract_Emails_And_Tasks()
Application.ScreenUpdating = False

Dim sCurrentFolder As String
sCurrentFolder = ActiveWorkbook.Path & "\"

Dim FSO As Scripting.FileSystemObject
Set FSO = New Scripting.FileSystemObject

Dim fldrOutlookIn As Scripting.Folder
Set fldrOutlookIn = FSO.GetFolder(sCurrentFolder & csOutlookIn)

Dim oApp As Outlook.Application
Set oApp = New Outlook.Application

Dim oTask As Outlook.TaskItem
Dim oMail As Outlook.MailItem
Dim oAttach As Outlook.Attachment

Dim fileItem As Scripting.File
Dim sAttachName As String
Dim lcounter As Long
lcounter = 0
Dim scounter As String
For Each fileItem In fldrOutlookIn.Files
    If Right(fileItem.Name, 4) <> ".msg" Then GoTo NextFile
    On Error Resume Next
    Set oTask = oApp.CreateItemFromTemplate(fileItem.Path)
    Set oMail = oApp.CreateItemFromTemplate(fileItem.Path)
    For Each oAttach In oTask.Attachments
        sAttachName = oAttach.Filename
        lcounter = lcounter + 1
        scounter = Format(lcounter, "000")
        sAttachName = sCurrentFolder & csOutlookOut & "\" & csFilePrefix & scounter & "_" & sAttachName
        oAttach.SaveAsFile sAttachName
    Next oAttach
    On Error GoTo 0
    If Not oTask Is Nothing Then
        Set oTask = Nothing
    End If
    If Not oMail Is Nothing Then
        Set oMail = Nothing
    End If
NextFile:
Next fileItem

MsgBox "Done!"
Application.ScreenUpdating = True
End Sub

Home

Demo 1- Extract Outlook Attachments with Excel VBA

Demo 2 – Avoid Duplicates While Extracting Attachments

Demo 3 – Error Handling

Extract Attachments from Outlook Tasks

Extract Emails and Tasks

Related Posts

Use Functions With Dynamic Arrays and Dictionaries

Select Dataset Except For Top Row

Download Attachments From Outlook Emails