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:

Option Explicit

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"
        ItemSaveAs strDestFolder & strFileName, olMSG
    End If
End Sub

Public Function RemoveInvalidChar(ByVal 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(ByVal 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(ByVal 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\" ' 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"
    ItemSaveAs 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.

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.