How to save attachments from all selected Outlook items to the hard drive

Applies to: Microsoft Outlook 2000/2002/2003/2007/2010

The macro below saves the attachments from all selected in Outlook items to the hard drive.

The strDestFolderPath (*1) variable sets the target folder on the hard drive, the macro then creates a subfolder with the same name as the folder in Outlook that contains selected items (*3) (Windows Vista and Windows 7 users - make sure you have full rights to create items in the target folder. By default folders My Documents and Desktop have these rights). Next the macro processes all selected items – not only email messages but also other Outlook items. All olByValue (files) and olEmbeddeditem (other Outlook items) attachments (*4) are saved to the hard drive. The olOLE (embedded OLE objects) attachments are not saved with the Outlook API functions and the olByReference (reference to the file) attachment is not in use anymore.

If the bDeleteAttach (*2) variable is set True, then all saved attachments are also removed from the original items (*5). The Attachments::Remove function is not present in the macro because it is not working in Outlook 2000.

After processing the selected items the macro marks them so they won’t be processed when the macro is executed again (*6).

Sub SaveAttachments()
    On Error Resume Next

    ' (*1) The path to the main saved attachments  folder
    Dim strDestFolderPath
    strDestFolderPath = "C:\temp\attachments\"

    ' (*2) To remove attachments from the original items change the value below to True
    Const bDeleteAttach = False

    ' (*3) Create the same folder as the item’s one in Outlook
    fso = CreateObject("Scripting.FileSystemObject")
    fso.CreateFolder(strDestFolderPath)

    Dim oFolder As MAPIFolder
    oFolder = Application.ActiveExplorer.CurrentFolder

    strDestFolderPath = strDestFolderPath & oFolder.Name & "\"
    fso.CreateFolder(strDestFolderPath)

    ' Process all items in the current folder
    For Each Item In Application.ActiveExplorer.Selection
        If Item.Attachments.Count > 0 And Item.UserProperties.Item("processed").Value <> 1 Then

            ' Here the macro marks the already processed items
            ReDim arAttachIndexes(0) As Integer

            ' Save all attachments
            For Each attach In Item.Attachments
                Dim oAttach As Attachment
                oAttach = attach

                ' (*4)
                If oAttach.Type = olByValue Or oAttach.Type = olEmbeddeditem Then

                    oAttach.SaveAsFile(strDestFolderPath & oAttach.FileName)

                    ' Preserve the attachment indexes
                    ReDim Preserve arAttachIndexes(UBound(arAttachIndexes) + 1)
                    arAttachIndexes(UBound(arAttachIndexes)) = oAttach.Index
                End If
            Next

            If Not IsEmpty(arAttachIndexes) Then

                If bDeleteAttach Then
                    ' (*5) Remove all previously saved attachments
                    For Index = UBound(arAttachIndexes) To 1 Step -1
                        Dim att : att = Item.Attachments(arAttachIndexes(Index))
                        att.Delete()
                    Next
                End If
            End If

            ' (*6) Mark as processed
            Item.UserProperties.Add("processed", olNumber)
            Item.UserProperties.Item("processed").Value = 1
            Item.Save()

        End If

    Next

End Sub