VBA Tools

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.