VBATools

Archiwizacja poczty, export do plików MSG

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

Przeraża was cykliczne wykonywanie kopii zapasowych lub nie wiecie, jakiej wersji Outlooka będziecie używać za kilka lat?

Na to pytanie niestety nikt nie zna odpowiedzi, sprawdzającej się w 100%, jednakże już dziś możecie wykonać pewien ruch, który was w pewien sposób zabezpieczy. Można dodać poniższe procedury, automatycznie eksportujące wiadomości do katalogu na dysk (bez względu, na to na jakie konto zostają one nadane czy z jakiego są odebrane*).

Dla poczty wychodzącej:

Umieszczamy wywołanie procedury w klasie “ThisOutlookSession

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Call ExportOutcomingMailToFile(Item)
End Sub

oraz umieszczamy poniższy kod w module:

Option Explicit

Public Sub ExportOutcomingMailToFile(ByVal Item As Object)
 If Item.Class = 43 Then
 On Error Resume Next
 Dim strDestFolder$: strDestFolder = "c:\PostOut" 'jakakolwiek ścieżka
 Call MakeWholePath(strDestFolder)
 On Error GoTo 0

 Dim strSubject$: strSubject = RemoveInvalidChar(Left(Item.Subject, 100))
 Dim strDate$: strDate = Format(Item.CreationTime, "YYYY-DD-MM_HH-MM")
 Dim strFileName$: strFileName = strDate & " " & strSubject & ".msg"
 Item.SaveAs strDestFolder & strFileName, olMSG
 End If
 End Sub

 Public 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

 Public 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

 Public Sub MakeWholePath(FileWithPath As String)
 'MVP OShon from VBATools.pl
 Dim x&, PathToMake$
 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

Dla poczty przychodzącej:

*można stworzyć regułę, którą swobodnie, selektywnie ograniczymy eksport w kreatorze przy pomocy tej procedury.

Sub ExportIncomingMailToFile(item As MailItem)
 On Error Resume Next
 Dim strDestFolder$: strDestFolder = "c:\PostIn" ' your any path
 Call MakeWholePath(strDestFolder)
 On Error GoTo 0

 Dim strSubject$: strSubject = RemoveInvalidChar(Left(item.Subject, 100))
 Dim strDate$: strDate = Format(item.CreationTime, "YYYY-DD-MM_HH-MM")
 Dim strFileName$: strFileName = strDate & " " & strSubject & ".msg"
 item.SaveAs strDestFolder & strFileName, olMSG
End Sub

Archiwizacja-poczty1

Rys 1. Dodanie reguły exportu wiadomości do pliku msg.

Przytoczone w powyższych procedurach parametry można dowolnie edytować wykorzystując właściwości obiektu Mailitem, a dla poczty przychodzącej mamy do dyspozycji kreatora. Więcej na temat reguł i skryptów w tym artykule.

 

(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.
:, , , ,

4 Comments for this entry

  • Robert Gajdzik

    dzięki za
    Archiwizacja poczty, export do plików MSG
    czegoś takiego szukałem od dawna. Super.

    • Oskar

      Odnośnie twojego pytania.

      A jak napisać skrypt dodająy datę+godz+min+sekundy do plików zapisywanych na dysk spod dowolnej aplikacji, techniką drag-drop? 😉 Chodzi o to by nigdy nie nastapilo nadpisanie.

      Jeśli sprawdzisz kod to jest pobierana wartość utworzenia obiektu Format(Item.CreationTime, "YYYY-DD-MM_HH-MM")
      Wystarczy do niego dodać -SS a otrzymasz zapis w sekundach.
      Metoda Drag’n’drop nadpisuje pliki i to makro jest naprawą błędu jakie powoduje utracenie wiadomości. Nie da się tego procesu poprawić (ponieważ nie jest przekazywany inny parametr poza tematem obiektu) to też korzystaj z pow kodu.

      Jeśli masz inne pytania zapraszam na http://www.outlook.pl
      OShon

  • Michał

    Skrypt działa poprawnie, jednak nie mogę poradzić sobie z moim problemem.

    Mianowicie stworzyłem sobie konto mailowe, na które przychodzą wiadomości odebrane przekierowane z 20 innych kont. I tutaj chciałbym stworzyć skrypt, który tworzył by nazwe folderu na podstawie odbiorcy z maila który mi przekierowuje.

    Czyli np. maile z kont: a1@bb.pl oraz a2@bb.pl są przekierowane na konto all@bb.pl i własnie skrypt na tym koncie all@bb.pl miałby tworzyć mi foldery o nazwie np. a1@bb.pl i a2@bb.pl i wrzucać do nich odpowiednio pliki MSG.

    Jak wyciągnąć z MailItem informację o odbiorcach maili, których nazwa lub alias byłby równocześnie nazwą folderu??

Leave a Reply