How to Auto Extract Embedded Images from Specific Incoming Emails via Outlook VBA

If you want Outlook to auto extract and save the embedded images from the specific incoming emails, you can refer to this article. Here we will teach you how to realize it with VBA code.

Some users frequently need to extract the embedded images from the specific incoming emails and save them to a certain Windows folder. It is so troublesome to manually do that every time. Therefore, many look forward to learning a quick and convenient approach to let Outlook auto accomplish that. Now, here we will share such a method with you.

Auto Extract Embedded Images from Specific Incoming Emails

1. Firstly, launch your Outlook program as usual.
2. Then, trigger Outlook VBA editor as usual with reference t “How to Run VBA Code in Your Outlook“.
3. Later, copy and paste the following VBA code into the “ThisOutlookSession” project.

Public WithEvents objInbox As Outlook.Folder
Public WithEvents objInboxItems As Outlook.Items

Private Sub Application_Startup()
    Set objInbox = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
    Set objInboxItems = objInbox.Items
End Sub

Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
    Dim objMail As Outlook.MailItem
    Dim objAttachments As Outlook.Attachments
    Dim objAttachment As Outlook.Attachment
    Dim strWindowsFolder As String
    Dim i As Long
 
    If TypeOf Item Is MailItem Then
       Set objMail = Item
 
       'Specify the emails as per your needs
       If objMail.Importance = olImportanceHigh Then
          Set objAttachments = objMail.Attachments
 
          'Specify the windows folder
          strWindowsFolder = "E:\" & objMail.Subject & Format(Now, "yymmddhhmmss")
          MkDir (strWindowsFolder)
 
          'Save all embedded images to the folder
          For i = 1 To objAttachments.Count
              Set objAttachment = objAttachments.Item(i)
              If IsEmbedded(objAttachment) = True Then
                 objAttachment.SaveAsFile strWindowsFolder & "\" & objAttachment.FileName
              End If
          Next
      End If
    End If
End Sub

Function IsEmbedded(objCurAttachment As Outlook.Attachment) As Boolean
    Dim objPropertyAccessor As Outlook.PropertyAccessor
    Dim strProperty As String
 
    Set objPropertyAccessor = objCurAttachment.PropertyAccessor
    strProperty = objPropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001E")
 
    If InStr(1, strProperty, "@") > 0 Then
       IsEmbedded = True
    Else
       IsEmbedded = False
    End If
End Function

4. After that, click into the “Application_Startup” subroutine.
5. Finally, click “F5” key to trigger this macro.
6. From now on, every time when a specific new email arrives in the Inbox, the embedded images will be saved to the specific Windows folder, as shown in the following screenshot.

Clean up Large Attachments Regularly

It is advisable to clean up large attachments from your Outlook on a regular basis. It aims to keep your Outlook file in appropriate size. Larger Outlook file is more susceptible to corruption. As you know, PST damage is quite difficult to be dealt with well. Maybe you will firstly attempt to fix it via inbox repair tool. However, in most of the cases, it won’t work. Your only resort is a specialized PST repair tool, like DataNumen Outlook Repair, or relevant professional recovery services.

Author Introduction:

Shirley Zhang is a data recovery expert in DataNumen, Inc., which is the world leader in data recovery technologies, including mdf fix and outlook repair software products. For more information visit www.datanumen.com