Export poprzez makro jako metoda na duplikaty wiadomości

Wiele osób podczas wielokrotnego odzyskiwania wiadomości z plików PST (przenoszenie lub reinstalacja MS Outlook), jak i problemów z przedwczesnym rozłączaniem klienta poczty z serwerem, uzyskuje wielokrotnie zduplikowane wiadomości.

Metodą na pozbycie się duplikatów jest możliwość hurtowego exportu wiadomości do plików .msg (wraz z załącznikami), a następnie umieszczenie ich z powrotem w MS Outlook. Ręczną metodą przeciągania wiadomości na dysk nie uzyskamy pozytywnego rezultatu, konieczne będzie makro.

Przed wykonaniem procedury, można utworzyć nowy folder, do którego przeniesiemy wszystkie wiadomości (tym sposobem pozbędziemy się późniejszych pytań „czy starą wiadomość zastąpić”.)

Cechą charakterystyczną dla opisanego eksportu jest to, iż w poniższym Makro, umieszczono domyślnie wpisanie daty wraz z tematem wiadomości i niezbędną dla prawidłowego funkcjonowania procedury usunięcie znaków zastrzeżonych. Mechanizm zapisuje wiadomości do katalogu c:\poczta\ nadpisując duplikaty. Po jego wykonaniu, wszystkie wiadomości będą występowały jednokrotnie.

Przeprowadzenie operacji pozbycia się duplikatów możemy opisać w kilku krokach:

1. Przenosimy wszystkie podwójne wiadomości do nowo utworzonego folderu w MS Outlook (pomocny w tym może obyć artykuł: Jak szybko usunąć zduplikowane wiadomości w programie Outlook) lub wszystkich wiadomości (dłuższe oczekiwanie na zakończenie procedury).
2. Zaznaczamy wiadomości w rozpatrywanym folderze, i uruchomiamy makro przyciskiem lub przy wywołaniu procedury skrótem klawiszowym Alt+F8 (aby osadzić procedurę MSG_Export pod przyciskiem w menu MS Outlook, polecam uwadze artykuł: Instalacja i uruchamianie makr).
3. Po zakończeniu exportu zaznaczamy pliki .msg z katalogu c:\poczta\ i przenosimy je myszą do MSOutlook (lub jako Ctrl+C w katalogu i Ctrl+V w docelowym folderze Outlooka).
4. Usuwamy, po wcześniejszym sprawdzeniu prawidłowości działania Makra, utworzony folder exportu oraz katalog na dysku (bądź archiwizujemy pliki .msg).

Option Explicit

Private Sub MSG_Export()
    On Error Resume Next
    Dim strDestFolder As String, fso As Object, item
        strDestFolder = "c:\poczta\"

    Set fso = CreateObject("Scripting.FileSystemObject")
    fso.CreateFolder strDestFolder
    On Error GoTo blad

    For Each item In Application.ActiveExplorer.Selection
        Dim strSubject As String: strSubject = RemoveInvalidChars(Left(item.Subject, 100))
        Dim strDate As Date: strDate = RemoveInvalidChars(item.SentOn)
              
        Dim strFileName As String
        If Application.ActiveExplorer.CurrentFolder.DefaultItemType = olMailItem Then
                strFileName = strDate & " " & strSubject & ".msg"
        Else
                strFileName = strSubject & ".msg"
        End If
        item.SaveAs strDestFolder & strFileName, olMSG
    Next
    Set fso = Nothing

MsgBox "Proces exportu wiadomości do plików MSG zakończono.", vbInformation, "Informacja dodatkowa"
Exit Sub

blad:
MsgBox "Błąd exportu plików MSG" & vbCr & vbCr _
     & Err.Number & vbCr _
     & Err.Description, vbCritical, "Informacja o błędzie"
End Sub

Public Function RemoveInvalidChars (str As String)
   Dim f As Long
   For f = 1 To Len(str)
      str = Replace(str, Mid$("\/:?""<>|*", f, 1), vbNullString)
   Next
   str = Replace(str, vbTab, vbNullString)
   str = Replace(str, vbCrLf, vbNullString)

   RemoveInvalidChars = str
End Function