
Archiwizacja poczty - automatyczny export do plików MSG
tagi: archiwizacja, automatyczny, export, MSG, plików, poczta
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
© Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.