Way to save all attachments form multiple emails at once

[Joey Cheung]

Hi everyone,

I am looking for a way to save all of the attachments from multiple emails at once (without opening each of the emails and save the attachments one by one).

Are there any built-in function in Outlook 2010 for me to do so?

Thanks a lot!

[gmayor]

There is no built-in function, but you can do it with a few macros e.g. as follows. Change the path to where you want to save the attachments. On a large folder this could take some time to run.

Option Explicit

Sub SaveAttachments()
Const strPath As String = "C:\Path\Message Attachments\"
Dim strFilename As String
Dim olFolder As Folder
Dim olItem As MailItem
Dim olAttach As Attachment
Dim i As Long
    MsgBox "Wait for 'Process Complete Message'"
    CreateFolders strPath        'Create the folder if it doesn't exist
    Set olFolder = Application.Session.PickFolder
    olFolder.Items.Sort "[Received]", True
    For i = 1 To olFolder.Items.Count
        Set olItem = olFolder.Items(i)
        If olItem.Attachments.Count > 0 Then
            For Each olAttach In olItem.Attachments
                If Not olAttach.Filename Like "image*.*" And _
                   Not olAttach.Filename Like "Untitled attachment*.*" Then
                    strFilename = olAttach.Filename
                    strFilename = FileNameUnique(strPath, _
                                                 strFilename, _
                                                 Right(strFilename, Len(strFilename) - InStrRev(strFilename, Chr(46))))
                    olAttach.SaveAsFile strPath & strFilename
                End If
            Next olAttach
        End If
        DoEvents
    Next i
    MsgBox "Process Complete"
    Set olFolder = Nothing
    Set olAttach = Nothing
    Set olItem = Nothing
    Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
                               strFilename As String, _
                               strExtension As String) As String
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(strFilename) - (Len(strExtension) + 1)
    strFilename = Left(strFilename, lngName)
    Do While FileExists(strPath & strFilename & Chr(46) & strExtension) = True
        strFilename = Left(strFilename, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    FileNameUnique = strFilename & Chr(46) & strExtension
lbl_Exit:
    Exit Function
End Function

Private Function CreateFolders(strPath As String)
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & "\"
        If Not FolderExists(strPath) Then MkDir strPath
    Next lngPath
lbl_Exit:
    Exit Function
End Function

Private Function FolderExists(ByVal PathName As String) As Boolean
Dim lngAttr As Long
    On Error GoTo NoFolder
    lngAttr = GetAttr(PathName)
    If (lngAttr And vbDirectory) = vbDirectory Then
        FolderExists = True
    End If
NoFolder:
    Exit Function
End Function