Have you ever wondered how to export graphics used in e-mails? The easiest way to do that is using right-click (Save As option) or making a screenshot by hitting PrtScr button and editing the image in Microsoft Paint. The problems start when there are a number of images in a message, and the exporting process needs to be done frequently and therefore becomes tiring.

Graphics used in an e-mail (JPG, PNG, BMP etc.) is nothing more than attachments, but differently inserted into the message. As such, they can’t be selected and saved in desired location, although Microsoft Outlook aims to achieve this feature.

The macro below, when applied to an open e-mail message, export attachments and graphics from the e-mail. What’s more, those are saved to subfolders in C:\Temp folder, under a name containing the e-mail’s date and subject (modifiable in the e-mail’s source code). This feature can be quite useful if a sender pastes an image into a message body instead of attaching it, or the image is an advertising item, which could be used in different situation.

Option Explicit On

Sub SavePicturesNAttachFromMess()
    Dim MyItem As MailItem
    On Error Resume Next
    Select Case TypeName(Application.ActiveWindow)
        Case "Explorer"
            MyItem = ActiveExplorer.Selection.item(1)
            MyItem.Display()
        Case "Inspector"
            MyItem = ActiveInspector.CurrentItem
        Case Else
    End Select
    On Error GoTo 0

    If MyItem Is Nothing Then
        MsgBox("Select message or open it!", vbExclamation, "VBATools.pl")
        Exit Sub
    End If

    Dim oAttach As Attachment, pict As Object, file$, ile&
    For Each pict In MyItem.Attachments
        DoEvents()
        oAttach = pict
        file = "c:\temp\" & RemoveInvalidChar(Format(MyItem.CreationTime, _
        "Short date") & " " & MyItem.Subject) & "\" & oAttach.fileName
        Call MakeWholePath(file)
        oAttach.SaveAsFile(file)
        ile = ile + 1
    Next pict
    If ile > 0 Then MsgBox("You have Just exported " & ile & " file(s) to " & Chr(34) & _
    "c:\temp\Folder subject.." & Chr(34) & " from a message:" & vbCr & Chr(34) & _
    MyItem.Subject & Chr(34), vbInformation, "OShon from VBATools.pl")
    MyItem = Nothing
    oAttach = Nothing
End Sub

Private Sub MakeWholePath(ByVal FileWithPath$)
    Dim x&, PathToMake$ 'by OShon
    For x = LBound(Split(FileWithPath, "\")) To UBound(Split(FileWithPath, "\")) - 1
        PathToMake = PathToMake & "\" & Split(FileWithPath, "\")(x)
        If Right$(PathToMake, 1) <> ":" Then
            If FileExists(Mid(PathToMake, 2, Len(PathToMake))) = False Then _
            MkDir(Mid(PathToMake, 2, Len(PathToMake)))
        End If
    Next
End Sub

Private Function RemoveInvalidChar(ByVal str As String)
    Dim f&
    For f = 1 To Len(str)
        str = Replace(str, Mid$("\/:?""<>|*", f, 1), vbNullString)
    Next
    str = Replace(str, vbTab, vbNullString)
    str = Replace(str, vbCrLf, vbNullString)
    RemoveInvalidChar = str
End Function

Private Function FileExists(ByVal FilePath As String) As Boolean
    On Error GoTo blad
    FileExists = Len(Dir(FilePath, vbDirectory Or vbHidden Or vbSystem)) > 0
    Exit Function
blad:
    FileExists = False
    End

If you are not experienced in macro installation, please refer to this article .

---

 (c) Shon Oskar 
© All rights reserved. No part or whole of this article may not be reproduced or published without prior permission.
Oryginal article publicate at this page