Macros Are for Outlook Too

Many people may not be aware that Visual Basic can be run from Outlook, not just Word and Excel. The next time you need to save attachments from a large group of emails try this macro:

If you're using Outlook 2010 first make sure that the 'Developer' tab is activated on the Ribbon. Go to File ... Optoin . . . Customize Ribbon, and check off 'Developer' in the Main Tabs section. Then press Alt + F11 and paste the below macro in a new module. Save and Close. Select the group of emails that you want to extract the attachments from. Then on the 'Developer' tab, choose Macros, and then click 'Project1.SaveAllAttachments'. You will then be prompted to save the attachments to a folder on your hard drive or network. As you can see there is also option to delete the attachments in the emails. This is nifty little tool to have on hand when dealing with electronic productions. Thanks very much to Technic Lee for posting this macro on his blog. See : https://techniclee.wordpress.com/2011/09/05/savingdeleting-all-attachments-with-one-click/

Sub DeleteAllAttachments()

Dim olkMsg As Object, intIdx As Integer

For Each olkMsg In Application.ActiveExplorer.Selection

For intIdx = olkMsg.Attachments.Count To 1 Step -1

If Not IsHiddenAttachment(olkMsg.Attachments.Item(intIdx)) Then

olkMsg.Attachments.Item(intIdx).Delete

End If

Next

olkMsg.Close olSave

Set olkMsg = Nothing

Next

End Sub

Sub SaveAllAttachments()

Const msoFileDialogFolderPicker = 4

Dim olkMsg As Object, intIdx As Integer, excApp As Object, strPath As String

Set excApp = CreateObject("Excel.Application")

With excApp.FileDialog(msoFileDialogFolderPicker)

.Show

For intIdx = 1 To .SelectedItems.Count

strPath = .SelectedItems(intIdx)

Next

End With

If strPath <> "" Then

For Each olkMsg In Application.ActiveExplorer.Selection

For intIdx = olkMsg.Attachments.Count To 1 Step -1

If Not IsHiddenAttachment(olkMsg.Attachments.Item(intIdx)) Then

olkMsg.Attachments.Item(intIdx).SaveAsFile strPath & "\" & olkMsg.Attachments.Item(intIdx).FileName

End If

Next

olkMsg.Close olDiscard

Set olkMsg = Nothing

Next

End If

Set excApp = Nothing

End Sub

Private Function IsHiddenAttachment(olkAttachment As Outlook.Attachment) As Boolean

'Purpose: Determines if an attachment is embedded.'

'Written: 10/12/2010'

'Outlook: 2007'

Dim olkPA As Outlook.PropertyAccessor

On Error Resume Next

Set olkPA = olkAttachment.PropertyAccessor

IsHiddenAttachment = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x7ffe000b")

On Error GoTo 0

Set olkPA = Nothing

End Function