Zapis grafiki oraz załączników użytych w wiadomości email

Zastanawiacie się jak eksportować grafikę użytą w wiadomościach?

Najprostszym sposobem jest prawy klik (zapisz jako) lub przycisk Print Screen oraz edycja grafiki w programie MS Paint. Kłopot w tym, jeśli mamy wiele obiektów w danej wiadomości a częstotliwość realizacji działań jest cykliczna i za razem męcząca.

Grafika użyta w wiadomości (JPG, PNG, BMP etc..) to nic innego jak załączniki, jednakże inaczej dodane do wiadomości. Nie można ich grupowo zaznaczyć i zapisać we wskazanym miejscu, choć w wersji 2010 są poczynione ku temu odpowiednie kroki.

Poniższa procedura na otwartej lub zaznaczonej wiadomości eksportuje załączniki oraz grafikę w niej użytą. Co więcej, zapis jest realizowany do podkatalogów w “C:\Temp\” o nazwie daty i temacie wiadomości (którą to można zmodyfikować w kodzie). Taka funkcjonalność może być przydatna, kiedy nasz adresat zamiast dodać zdjęcia z wakacji wklei je do treści wiadomości, lub przesłany materiał reklamowy umieszczony w wiadomości chcemy użyć w innych warunkach. 

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("Zaznacz wiadomość lub ją otwórz!", 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("Właśnie eksportowałeś " & ile & " plik(ów) do " & xhr(34) & _
        "c:\temp\Katalogu tematu.." & xhr(34) & " z wiadomości:" & vbCr & xhr(34) & _
        MyItem.Subject & xhr(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

Shon Oskar – www.VBATools.pl

© Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.