VBATools

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

by on Nov.05, 2010, under Outlook, Porady

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

Najprostszym sposobem jest prawy klik (zapisz jako) lub PrsCr oraz dłubanie w programie MS Paint. Kłopot w tym jeśli mamy wiele obiektów w 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"
    Set MyItem = ActiveExplorer.Selection.item(1)
    MyItem.Display
  Case "Inspector"
    Set 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
 Set 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 " & Chr(34) & _
 "c:\temp\Katalogu tematu.." & Chr(34) & " z wiadomości:" & vbCr & Chr(34) & _
 MyItem.Subject & Chr(34), vbInformation, "OShon from VBATools.pl"
Set MyItem = Nothing
Set 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(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(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 Function

(c) 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.

:, , , , , ,

Leave a Reply

Recently Active Members

Profile picture of vbatools
Profile picture of Karol Stilger
Profile picture of Joanna Subik
Profile picture of Anorak
Profile picture of marcinmachalowski
Profile picture of programistaaccess
Profile picture of piotrpawlik
Profile picture of Emil Wasilewski
Profile picture of kicekpicek
Profile picture of coldfusion
Profile picture of Gosia Borzęcka
Profile picture of lukaszch
Profile picture of itadministracja
Profile picture of farbenia
Profile picture of Łukasz Kałużny
Profile picture of kabzinski
Profile picture of rtynski
Profile picture of leszekbetlinski
Profile picture of Iv
Profile picture of Justyna Spychała