Save and Delete Attachments from Outlook messages

The following is the Save Attachment code sample from Teach Yourself Outlook 2003 in 24 Hours. (It works in current versions.)

To use, first create a folder under your My Documents named OLAttachments. Then select one or more messages and run the macro to save and remove the attachments. (May wish to comment out the line that deletes the attachment before testing). Remove or comment out the MsgBox lines after testing.

To delete the attachments without saving them, leave just these lines between the If... and End if. (The macro can also be edited to remove the statements above the If command that are no longer needed.)

If lngCount > 0 Then
 For i = lngCountb To 1 Step -1
 
 ' Delete the attachment.
 objAttachments.Item(i).Delete
 
 Next i
 objMsg.Save
 
 End If

In Outlook, press Alt+F11 to open the VBA editor and expand Microsoft Outlook Objects then double click on ThisOutlookSession to open it in the editing pane and Ctrl+V to paste the code.

Public Sub SaveAttachments()
 Dim objOL As Outlook.Application
 Dim objMsg As Outlook.MailItem 'Object
 Dim objAttachments As Outlook.Attachments
 Dim objSelection As Outlook.Selection
 Dim i As Long
 Dim lngCount As Long
 Dim strFile As String
 Dim strFolderpath As String
 Dim strDeletedFiles As String

    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    On Error Resume Next

     ' Instantiate an Outlook Application object.
     Set objOL = CreateObject("Outlook.Application")

     ' Get the collection of selected objects.
     Set objSelection = objOL.ActiveExplorer.Selection

     ' Set the Attachment folder.
     strFolderpath = strFolderpath & "OLAttachments"

     'Use the MsgBox command to troubleshoot. Remove it from the final code.
     MsgBox strFolderpath
 
     ' Check each selected item for attachments. If attachments exist,
     ' save them to the Temp folder and strip them from the item.
     For Each objMsg In objSelection

     ' This code only strips attachments from mail items.
     ' If objMsg.class=olMail Then
     ' Get the Attachments collection of the item.
     Set objAttachments = objMsg.Attachments
     lngCount = objAttachments.Count

     'Use the MsgBox command to troubleshoot. Remove it from the final code.
     MsgBox objAttachments.Count

     If lngCount > 0 Then

     ' We need to use a count down loop for removing items
     ' from a collection. Otherwise, the loop counter gets
     ' confused and only every other item is removed.
     
     For i = lngCount To 1 Step -1
     
     ' Save attachment before deleting from item.
     ' Get the file name.
     strFile = objAttachments.Item(i).FileName
     
     ' Combine with the path to the Temp folder.
     strFile = strFolderpath & strFile
     
     ' Save the attachment as a file.
     objAttachments.Item(i).SaveAsFile strFile
     
     ' Delete the attachment.
     objAttachments.Item(i).Delete
     
     'write the save as path to a string to add to the message
     'check for html and use html tags in link
     If objMsg.BodyFormat <> olFormatHTML Then
         strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
         Else
         strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _ strFile & "'>" & strFile & "</a>"
     End If
     
     'Use the MsgBox command to troubleshoot. Remove it from the final code.
     MsgBox strDeletedFiles
     
     Next i
     'End If
     
     ' Adds the filename string to the message body and save it
     ' Check for HTML body
     If objMsg.BodyFormat <> olFormatHTML Then
         objMsg.Body = objMsg.Body & vbCrLf & _
         "The file(s) were saved to " & strDeletedFiles
     Else
         objMsg.HTMLBody = objMsg.HTMLBody & "</p> <p>" & _
         "The file(s) were saved to " & strDeletedFiles & "</p> <p>"
     End If
         objMsg.Save
 'sets the attachment path to nothing before it moves on to the next message. 
         strDeletedFiles = ""
 
     End If
     Next
     
 ExitSub:
 
 Set objAttachments = Nothing
 Set objMsg = Nothing
 Set objSelection = Nothing
 Set objOL = Nothing
 End Sub 

Frank's Modification

Frank modified the structure to break the code into a single call for each mail item. This way, the code can be used for all items selected, but at the same time a RULE can invoke the code also when incoming mail hits the box. here’s the modification.

Public Sub SaveAttachments()
    Dim objOL As Outlook.Application
    Dim pobjMsg As Outlook.MailItem 'Object
    Dim objSelection As Outlook.Selection

    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")

    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection

    For Each pobjMsg In objSelection
        SaveAttachments_Parameter pobjMsg
    Next

ExitSub:

    Set pobjMsg = Nothing
    Set objSelection = Nothing
    Set objOL = Nothing
End Sub

Public Sub SaveAttachments_Parameter(objMsg As MailItem)
    Dim objAttachments As Outlook.Attachments
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolderpath As String
    Dim strDeletedFiles As String

    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    On Error Resume Next

    ' Set the Attachment folder.
    strFolderpath = strFolderpath & "OLAttachments"

        ' Get the Attachments collection of the item.
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count

        If lngCount > 0 Then

            ' We need to use a count down loop for removing items
            ' from a collection. Otherwise, the loop counter gets
            ' confused and only every other item is removed.
            For i = lngCount To 1 Step -1

                ' Save attachment before deleting from item.
                ' Get the file name.
                strFile = objAttachments.Item(i).FileName

                ' Combine with the path to the Temp folder.
                strFile = strFolderpath & strFile

                ' Save the attachment as a file.
                objAttachments.Item(i).SaveAsFile strFile

                ' Delete the attachment.
                'objAttachments.Item(i).Delete

                'write the save as path to a string to add to the message
                'check for html and use html tags in link
                If objMsg.BodyFormat  olFormatHTML Then
                    strDeletedFiles = strDeletedFiles & vbCrLf & ""
                    Else
                    strDeletedFiles = strDeletedFiles & "" & "" & strFile & ""
                End If
            Next i
        End If

        ' Adds the filename string to the message body and save it [COMMENTED AS THIS FUNCTION WAS NOT DESIRED]
        ' Check for HTML body
        '        If objMsg.BodyFormat  olFormatHTML Then
        '            objMsg.Body = objMsg.Body & vbCrLf & _
        '            "The file(s) were saved to " & strDeletedFiles
        '        Else
        '            objMsg.HTMLBody = objMsg.HTMLBody & "" & _
        '            "The file(s) were saved to " & strDeletedFiles & ""
        '        End If
        objMsg.Save
ExitSub:

    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objOL = Nothing
End Sub

Augusto's Modification

Augusto made some modifications on Frank’s code, in order to avoid file overwriting when the attachment name is the same as an existing one (i.e. details.txt on a return receipt email). Now, the attachments are saved in the format “SenderName.ReceivedDate.filename.ext” and then the attachment is deleted from the original email.

Here is Augusto's code:

Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim pobjMsg As Outlook.MailItem 'Object
Dim objSelection As Outlook.Selection
 
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
 
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
 
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
 
For Each pobjMsg In objSelection
SaveAttachments_Parameter pobjMsg
Next
 
ExitSub:
 
Set pobjMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
 
Public Sub SaveAttachments_Parameter(objMsg As MailItem)
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
 
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
 
' Set the Attachment folder.
strFolderpath = strFolderpath & "\OLAttachments\"
 
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
 
If lngCount > 0 Then
 
' We need to use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
 
' Save attachment before deleting from item.
' Get the file name.
strFile = objAttachments.Item(i).FileName
 
' Combine with the path to the Temp folder.
strFile = strFolderpath & objMsg.SenderName & "." & Format(objMsg.ReceivedTime, "yyyy-MM-dd h-mm-ss") & "." & strFile
 
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
 
' Delete the attachment.
objAttachments.Item(i).Delete
 
'write the save as path to a string to add to the message
'check for html and use html tags in link
If objMsg.BodyFormat olFormatHTML Then
strDeletedFiles = strDeletedFiles & vbCrLf & ""
Else
strDeletedFiles = strDeletedFiles & "" & "" & strFile & ""
End If
Next i
End If
 
' Adds the filename string to the message body and save it
' Check for HTML body
If objMsg.BodyFormat olFormatHTML Then
objMsg.Body = objMsg.Body & vbCrLf & _
"The file(s) were saved to " & strDeletedFiles
Else
objMsg.HTMLBody = objMsg.HTMLBody & "" & _
"The file(s) were saved to " & strDeletedFiles & ""
End If
objMsg.Save
ExitSub:
 
Set objAttachments = Nothing
Set objMsg = Nothing
Set objOL = Nothing
End Sub

Delete all attachments in the selected folder

Select a folder and run this code to process all messages in the current folder. The "magic" in this code is using the CurrentFolder object: Set Mail = objOL.ActiveExplorer.CurrentFolder instead of the Selection object.

Public Sub SaveDeleteAttachments()
 
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String

    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    On Error Resume Next
    strFolderpath = strFolderpath & "OLAttachments"

    Set objOL = CreateObject("Outlook.Application")
    Set Mail = objOL.ActiveExplorer.CurrentFolder
  
    For Each objMsg In Mail.Items

    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count

    If lngCount > 0 Then

    For i = lngCount To 1 Step -1

    strFile = objAttachments.Item(i).FileName
    strFile = strFolderpath & strFile

    objAttachments.Item(i).SaveAsFile strFile
    objAttachments.Item(i).Delete

    If objMsg.BodyFormat <> olFormatHTML Then
        strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
        Else
        strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
        strFile & "'>" & strFile & "</a>"
    End If
  
    Next i
    'End If

    If objMsg.BodyFormat <> olFormatHTML Then
        objMsg.Body = objMsg.Body & vbCrLf & _
        "The file(s) were saved to " & strDeletedFiles
    Else
        objMsg.HTMLBody = objMsg.HTMLBody & "<p>" & _
        "The file(s) were saved to " & strDeletedFiles & "</p>"
    End If
        objMsg.Save
        strDeletedFiles = ""

    End If
    Next

ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objOL = Nothing
End Sub