Save embedded pictures in their original format

You’ve probably come across this at least once; You receive a nicely HTML formatted message with embedded pictures so the sender can tell the story with the pictures.

In this case, you can’t use the “Save All Attachments” command to quickly save all the images that are included in the email.

The macro in this guide allows you to save all the embedded pictures in their original file format to a selected folder.

• SaveAllAttachments VBA macro
• Quick Install
• Macro Code

SaveAllAttachments VBA Macro

The SaveAllAttachments macro allows you to save all pictures that are shown in the message body (embedded) as well as all other attachments in their original file format.

When executing the macro you’ll save all attachments with a date and time stamp to a folder of choice. Note that it fully respects the list of blocked file types for attachments to prevent any security risks.

By adding a button for the macro to the main Outlook window and/or the opened Message item window, you have quick access to it similar to the native Save All Attachments command.

Quick Install

Use the following instructions to configure the macro in Outlook;

1. Download this code-file (saveallattachments.zip) or copy the code below.
2. Open the VBA Editor (keyboard shortcut ALT+F11)
3. Extract the zip-file and import the SaveAllAttachments.bas file via File-> Import…
   If you copied the code, paste it into a new module.
4. Add a reference to: Microsoft Shell Controls And Automation.
   Tools-> References…
5. Sign your code so you won’t get any security prompts and the macro won’t get disabled.
6. Add a button for easy access to the macro.

Add a button of the macro to the QAT for quick access to it.

Macro Code

The following code is contained in the zip-file referenced in the Quick Install. You can use the code below for review or manual installation.

'================================================================= 'Description: Outlook macro to save all pictures that are shown in ' the message body (embedded) as well as all other ' attachments in their original file format. ' 'Important! This macro requires a reference to: ' Microsoft Shell and Automation ' In VBA Editor: Tools-> References... ' 'author : Robert Sparnaaij 'version: 1.0 'website: https://www.howto-outlook.com/howto/saveembeddedpictures.htm '================================================================= Private Const BIF_RETURNONLYFSDIRS As Long = &H1 Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2 Private Const BIF_RETURNFSANCESTORS As Long = &H8 Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000 Private Const BIF_BROWSEFORPRINTER As Long = &H2000 Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000 Private Const MAX_PATH As Long = 260 Function BrowseFolder(Optional Caption As String, _ Optional InitialFolder As String) As String Dim SH As Shell32.Shell Dim F As Shell32.Folder Dim WshShell As Object Set SH = New Shell32.Shell Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder) Set WshShell = CreateObject("WScript.Shell") If Not F Is Nothing Then 'Special folders don't always return their full path that is why we check the title first Select Case F.Title Case "Desktop" BrowseFolder = WshShell.SpecialFolders("Desktop") Case "My Documents" BrowseFolder = WshShell.SpecialFolders("MyDocuments") Case "My Computer" MsgBox "Invalid selection", vbCritical + vbOKOnly, "Error" Exit Function Case "My Network Places" MsgBox "Invalid selection", vbCritical + vbOKOnly, "Error" Exit Function Case Else BrowseFolder = F.Items.Item.Path End Select End If 'Cleanup Set SH = Nothing Set F = Nothing Set WshShell = Nothing End Function Sub SaveAllAttachments() 'Get all selected items Dim objOL As Outlook.Application Dim objSelection As Outlook.Selection Dim objItem As Object Set objOL = Outlook.Application Set objSelection = objOL.ActiveExplorer.Selection 'Make sure at least one item is selected If objSelection.Count <> 1 Then Response = MsgBox("Please select a single item", vbExclamation, "Save all Attachments") Exit Sub End If 'Retrieve the selected item Set objItem = objSelection.Item(1) 'Retrieve all attachments from the selected item Dim colAttachments As Outlook.Attachments Dim objAttachment As Outlook.Attachment Set colAttachments = objItem.Attachments 'Here makes the user the folder selection Dim FolderPath As String FolderPath = BrowseFolder("Select a folder") If FolderPath = "" Then Response = MsgBox("Please select a folder. No items were saved", vbExclamation, "Save all Attachments") Exit Sub End If 'Save all attachments to the selected location with a date and time stamp of message to generate a unique name Dim DateStamp As String Dim MyFile As String For Each objAttachment In colAttachments MyFile = objAttachment.FileName DateStamp = Format(objItem.CreationTime, " - yyyymmdd_hhnnss") intPos = InStrRev(MyFile, ".") If intPos > 0 Then MyFile = Left(MyFile, intPos - 1) & DateStamp & Mid(MyFile, intPos) Else MyFile = MyFile & "DateStamp" End If objAttachment.SaveAsFile (FolderPath & "\" & MyFile) Next 'Cleanup Set objOL = Nothing Set objSelection = Nothing Set objAttachment = Nothing Set objItem = Nothing Set colAttachments = Nothing End Sub Click in the area above and press CTR+A to select all. Press CTRL+C to copy the code.