Archiwizacja poczty - automatyczny export do plików MSG

Cykliczne wykonywanie kopii zapasowych może wydawać się trochę czasochłonne i bezcelowe, tym bardziej, że często nie wiemy, jakiej wersji Outlooka będziemy używać za kilka lat.

Jednakże już dziś możemy wykonać pewne czynności w kierunku automatyzacji działań. Poniższe procedury, automatycznie eksportują wiadomości do katalogu na dysk (bez względu na to, na jakie konto zostają one nadane czy z jakiego są odebrane).

Wyeksportowane wiadomości można przeczytać uruchamiając zapisany plik lub przenieść je metodą kopiuj/wklej do odrębnego Outlooka (np. zainstalowanego na innym komputerze) bez przenoszenia i podpinania plików bazy danych PST.

Dla poczty wychodzącej:

Aby osadzić kod VBA należy otworzyć moduł developerski (Alt+F11) i osadzić poniższy kod w klasie "ThisOutlookSession": 

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

oraz umieścić poniższy kod w utworzonym module:

Public Sub ExportOutcomingMailToFile(ByVal Item As Object)
 If Item.Class = 43 Then
  On Error Resume Next
  Dim strDestFolder$: strDestFolder = "c:\Post\Out\" '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)
 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

Dla poczty przychodzącej:

Można stworzyć regułę, za pomocą której swobodnie, selektywnie ograniczymy eksport w kreatorze, umieszczając poniższy kod w module (dołączając pow. zamieszczone funkcje).

Sub ExportIncomingMailToFile(item As MailItem)
    On Error Resume Next
    Dim strDestFolder$ : strDestFolder = "c:\Post\In\" '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 Sub

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 reguł. Więcej na temat reguł i skryptów w dowiecie się w tym artykule.

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