VBA Tools

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:\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)
 '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:\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"
 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. 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.