Microsoft Outlook troubleshooting

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

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 ''" & _
        "c:\temp\Katalogu tematu..''" & " z wiadomości: ''" & vbCr & _
        MyItem.Subject & "''"), 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 Sub

MVP Shon Oskar – VBATools.pl
Jeśli masz pytania dot. tego artykułu zapraszam na Forum
Skonfiguruj swój pakiet dodatków do Excela, Worda, PowerPointa i Outlooka



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

Komentarze

Komentarze
OShon
OShon, VBATools.pl 2012-11-28 09:19:31
Ze względu na błąd edytora tego artykułu zaznaczam iż xhr należy zamienić na chr, a na końcu funkcji FileExists zamiast End powinno być End Function
OShon
OShon, VBATools.pl 2013-03-25 17:26:58
Artykuł poprawiono
leku
leku 2013-06-11 19:15:18
"c:tempKatalogu tematu..''" & " z wiadomości: ''" & vbCr & _ MyItem.Subject & "''"), Nawias ) chyba do usunięcia. Procedura nie działa u mnie. Pomimo zaznaczenia wiadomości dalej mam komunikat "Zaznacz wiadomość lub ją otwórz!"