VBATools

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