Przenoszenie wielkich maili do archiwum

Archiwizacja poczty w MS Outlook ogranicza się jedynie do czasowego określenia zakresu przenoszonych obiektów (Rys.1.), z możliwością wyłączenia obiektów, których nie chcemy archiwizować. Operacje ta można wykonać ręcznie, jak i automatycznie.

Rys.1. Standardowa opcja archiwizacji.

W przypadku jednak, kiedy interesuje nas opróżnienie głównego pliku bazy: Outlook.PST bez utraty pomniejszych wiadomości należy odfiltrować te, które zajmują najwięcej miejsca. Można wymusić export wiadomości podpinając ręcznie repozytorium archiwalnych wiadomości, jednakże z uwagi na dość liczną liczbę tych wiadomości (dobrym narzędziem do tego są foldery wyszukania) oraz ich rozproszenie w strukturze folderów (chcemy zachować ich przyporządkowanie do nazw folderów) jest to dość uciążliwe.

Aby wykonać czynność przeniesienia wiadomości „za jednym zamachem” należy zastosować kod VBA. Wywołując makro określamy ich granicę minimalną w KB (Rys.3.). Przedtem jednak koniecznym krokiem jest podłączenie pliku Archiwe.PST, który będzie zawierał główny folder o nazwie „Foldery archiwum”.

Kod sprawdzi do trzeciego wskazanego folderu w głąb wszystkie obiekty i odwzoruje ich strukturę przenosząc wiadomości spełniające warunek pojemności.

Option Explicit On
Sub Przenoszenie_wielkich_maili_do_archiwum()
    Dim olApp As Outlook.Application
    Dim olNs As Outlook.Namespace
    Dim destFolder As Outlook.MAPIFolder
    Dim OlFolder As Outlook.MAPIFolder
    Dim myFolder As Outlook.MAPIFolder
    Dim myNewFolder As Outlook.MAPIFolder
    Dim newProjectName$, wielkosc$

    olApp = New Outlook.Application
    olNs = olApp.GetNamespace("MAPI")
    OlFolder = olNs.PickFolder
    If OlFolder Is Nothing Then Exit Sub
    If OlFolder.DefaultItemType <> 0 Then
    MsgBox "Wpisanie inf do folderu " & xhr[34] & OlFolder.Name & xhr[34] & _
    " nie jest możliwe." & vbCr & "Wybierz folder poczty!", _
    vbExclamation, " Informacja o błędzie VBATools.pl": Exit Sub
    End If

    Dim olFolderUpper As Outlook.MAPIFolder
    Dim olFolderLower As Outlook.MAPIFolder
    Dim olFolderMoreLower As Outlook.MAPIFolder
    Dim olDocelowy As Outlook.MAPIFolder

    'Set olFolder = olNs.Folders("Foldery osobiste").Folders("Skrzynka odbiorcza").Folders("VBATools")

    On Error GoTo brak_arch
    destFolder = olNs.Folders("Foldery archiwum") 'nazwa folderu archiwum
    On Error GoTo 0

newProjectName = InputBox("Podaj nazwę nowego folderu w: " & vbCr & _
xhr[34] & destFolder.Name & xhr[34], "Tworzenie nowego folderu danych", "Beckup")
    If Len(Trim(newProjectName)) = 0 Then
        MsgBox("Nie podano folderu synxhronizacji." & vbCr & _
        "W nim będzie odtworzona struktura folderów z wiadomościami." & vbCr & vbCr & _
       "Operacja została przerwana!", vbExclamation, "Komunikat o błędzie VBATools.pl")
        Exit Sub
    End If

    wielkosc = InputBox("Podaj wielkość minimalną wagi wiadomości: " & vbCr & "Wielkość 1MB = 1024" & _
    vbCr & "Po zaakceptowaniu poczekaj na komunikat potwierdzający zakończenie działania makra.", _
    "Przenoszenie wiadomości", "1024")
    If IsNumeric(Trim(wielkosc)) = False Then
        MsgBox("Wielkość wiadomości musi być wykazana w KB." & vbCr & _
               "Dla przykładu 1MB = 1024KB." & vbCr & vbCr & _
               "Operacja została przerwana!", vbExclamation, "Komunikat o błędzie VBATools.pl")
        Exit Sub
    End If

    Call Make_folder(destFolder, newProjectName)
    Call Make_folder(destFolder.Folders(newProjectName), OlFolder.Name)
    olDocelowy = destFolder.Folders(newProjectName).Folders(OlFolder.Name)
    Call Kopiuj_maile(OlFolder, CLng(wielkosc), olDocelowy)
    For Each olFolderUpper In OlFolder.Folders
        'Debug.Print olFolderUpper.FolderPath, olFolderUpper.Items.Count, olFolderUpper.Folders.Count
        olDocelowy = destFolder.Folders(newProjectName).Folders(OlFolder.Name)
        Call Make_folder(olDocelowy, olFolderUpper.Name)
        Call Kopiuj_maile(olFolderUpper, CLng(wielkosc),
olDocelowy.Folders(olFolderUpper.Name))

        For Each olFolderLower In olFolderUpper.Folders
            'Debug.Print olFolderLower.FolderPath, olFolderLower.Items.Count
            olDocelowy = olDocelowy.Folders(olFolderUpper.Name)
            Call Make_folder(olDocelowy, olFolderLower.Name)
            Call Kopiuj_maile(olFolderLower, CLng(wielkosc),
olDocelowy.Folders(olFolderLower.Name))

            For Each olFolderMoreLower In olFolderLower.Folders
                'Debug.Print olFolderMoreLower.FolderPath, olFolderMoreLower.Items.Count
                olDocelowy = olDocelowy.Folders(olFolderLower.Name)
                Call Make_folder(olDocelowy, olFolderMoreLower.Name)
                Call Kopiuj_maile(olFolderMoreLower, CLng(wielkosc),
olDocelowy.Folders(olFolderMoreLower.Name))
            Next
        Next
    Next
    'Debug.Print destFolder.Name & "\" & newProjectName

MsgBox "Wykonano proces exportu wiadomości do " & xhr[34] & destFolder.Name & xhr[34], _        vbInformation, "VBATools.pl"
koniec:
    destFolder = Nothing
    OlFolder = Nothing
    olNs = Nothing
    olApp = Nothing
    Exit Sub
brak_arch:
MsgBox "Brak podpiętego pliku " & xhr[34] & "Archive.PST" & xhr[34] & vbCr & _
       "Klikając prawym klawiszem myszy na strukturę folderów wywołaj opcję: " & xhr[34] & _
       "Otwórz plik danych.." & xhr[34] & " i ponownie uruchom procedurę.", _
       vbExclamation, "VBATools.pl"
    Exit Sub
Blad:
    MsgBox("Numer błędu: " & Err.Number & vbCr & _
           "Opis: " & Err.Description, vbExclamation, "VBATools.pl")
    Resume koniec
End Sub

Private Sub Make_folder(ByVal parentFolder As MAPIFolder, ByVal newFolder$)
    Dim myNewFolder As MAPIFolder
    On Error GoTo dalej
    myNewFolder = parentFolder.Folders(newFolder)
    Exit Sub
dalej:
    On Error GoTo koniec
    myNewFolder = parentFolder.Folders.Add(newFolder)
    Exit Sub
koniec:
    Debug.Print("Numer błędu: " & Err.Number & _
           "Opis: " & Err.Description)
End Sub

Private Sub Kopiuj_maile(ByVal oFolder As MAPIFolder, ByVal oMailWaight&, ByVal destFolder As MAPIFolder)
    Dim item As MailItem
    Dim OlFolder As MAPIFolder
    Dim OldestFolder As MAPIFolder
    OlFolder = oFolder
    OldestFolder = destFolder
    On Error Resume Next
    For Each item In OlFolder.Items
        'DoEvents 'przydatne podczas podpięcia paska postępu
        If item.Size \ 1024 > oMailWaight Then
            'Debug.Print item.Subject & " " & item.Size \ 1024
            item.Move(destFolder)
        End If
    Next
    OlFolder = Nothing
    OldestFolder = Nothing
End Sub

 

Domyślnie podpowiadanym przez mechanizm folderem jest folder „Beckup” (lub dowolnie podany w wywołanym przez makro oknie), jednakże, jeśli nie chcemy a był utworzony wystarczy w zapytanie wpisać nazwę: „Foldery archiwum”, a struktura folderów będzie tworzona w głównym folderze tej bazy.

Rys.2. Tworzenie folderu nadrzędnego struktury folderów wielkich plików.

Rys.3. Określenie minimalnej wielkości przenoszonych plików.

Po uruchomieniu procedury komunikat potwierdzający zakończenie umożliwia dalszą pracę z programem. Aby jednak zrealizować cel, jakim jest pomniejszenie bazy danych należy przystąpić jeszcze do minimalizacji jej objętości.

Zmniejszenie pliku głównej bazy Outlooka i jednoczesne przywrócenie pierwotnej kondycji aplikacji jest jednak zależne od czynności zwanej, „kompaktowaniem”. Dostępna ona jest w we właściwościach folderu głównego: 

kliknij prawym klawiszem na Foldery osobiste, Właściwości, Zaawansowane, Kompaktuj

Rys.4. Kompaktowanie bazy.

Z uwagi na brak możliwości zaprogramowania tej czynności, należy ją wykonać ręcznie, według opisanej powyżej procedury.

Makro zostało przetestowane w programie Outlook 2007.

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.