Outlook macro to save attachments from all selected items

I recently used one of those scanner/copier/fax/do-it-all machines in the office to scan in several documents. Each time you scan in a document or set of documents, they get e-mailed to you as an attachment. To my knowledge, Outlook doesn’t have the ability to save attachments from several messages at once, so I wrote this macro. It will prompt for a foldername, then save all attachments from all currently selected items to that folder. Without further ado:

{% codeblock %}{% codeblock %}Public Sub SaveAllAttachments()

Dim olTask As Outlook.TaskItem Dim olItem As Outlook.MailItem Dim olExp As Outlook.Explorer Dim olApp As Outlook.Application Dim olAttach As Outlook.Attachment

Dim objWord As Object Set olApp = Outlook.CreateObject("Outlook.Application") Set olExp = olApp.ActiveExplorer

Dim cntSelection As Integer cntSelection = olExp.Selection.Count

‘Declare a variable as a FileDialog object. Dim fd As Office.FileDialog

’ Start word if necessary Set objWord = GetObject("", "Word.Application") If objWord Is Nothing Then Set objWord = CreateObject("Word.Application") End If

‘Create a FileDialog object as a File Picker dialog box. Set fd = objWord.FileDialog(msoFileDialogFolderPicker)

With fd .InitialView = msoFileDialogViewList If .Show = -1 Then Path = fd.SelectedItems(1) Else MsgBox "error" If objWord.Documents.Count = 0 Then objWord.Quit End If Exit Sub End If End With

If objWord.Documents.Count = 0 Then objWord.Quit End If

’ Loop through the selected mail items and save the attachments For i = 1 To cntSelection Set olItem = olExp.Selection.Item(i) For Each olAttach In olItem.Attachments olAttach.SaveAsFile Path & "" & olAttach.FileName Next olAttach Next

End Sub{% endcodeblock %}{% endcodeblock %}

Hope somebody out there finds it useful!