Przenoszenie wielkich maili do archiwum

by vbatools on Mar.19, 2011, under Outlook, Porady

Archiwizacja w MS Outlook ogranicza się jedynie do czasowego określenia zakresu przenoszonych obiektów (rys1), 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ą ich ilość (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 podczepienie 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

Sub Przenoszenie_wielkich_maili_do_archiwum()
'MVP OShon from VBATools.pl
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$

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set OlFolder = olNs.PickFolder
 If OlFolder Is Nothing Then Exit Sub
 If OlFolder.DefaultItemType <> 0 Then
 MsgBox "Wpisanie inf do folderu " & Chr(34) & OlFolder.Name & Chr(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
 Set destFolder = olNs.Folders("Foldery archiwum") 'nazwa folderu archiwum
On Error GoTo 0

newProjectName = InputBox("Podaj nazwę nowego folderu w: " & vbCr & _
Chr(34) & destFolder.Name & Chr(34), "Tworzenie nowego folderu danych", "Beckup")
If Len(Trim(newProjectName)) = 0 Then
 MsgBox "Nie podano folderu synchronizacji." & 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)

 Set 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
 Set 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
 Set 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
 Set 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 " & Chr(34) & destFolder.Name & Chr(34), _
 vbInformation, "VBATools.pl"
koniec:
 Set destFolder = Nothing
 Set OlFolder = Nothing
 Set olNs = Nothing
 Set olApp = Nothing
Exit Sub
brak_arch:
MsgBox "Brak podpiętego pliku " & Chr(34) & "Archive.PST" & Chr(34) & vbCr & _
 "Klikając prawym klawiszem myszy na strukturę folderów wywołaj opcję: " & Chr(34) & _
 "Otwórz plik danych.." & Chr(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(parentFolder As MAPIFolder, newFolder$)
 Dim myNewFolder As MAPIFolder
 On Error GoTo dalej
 Set myNewFolder = parentFolder.Folders(newFolder)
 Exit Sub
dalej:
 On Error GoTo koniec
 Set myNewFolder = parentFolder.Folders.Add(newFolder)
 Exit Sub
koniec:
Debug.Print "Numer błędu: " & Err.Number & _
 "Opis: " & Err.Description
End Sub

Private Sub Kopiuj_maile(oFolder As MAPIFolder, oMailWaight&, destFolder As MAPIFolder)
'MVP OShon from VBATools.pl
Dim item As MailItem
Dim OlFolder As MAPIFolder
Dim OldestFolder As MAPIFolder

Set OlFolder = oFolder
Set OldestFolder = destFolder
 On Error Resume Next
 For Each item In OlFolder.Items
 'DoEvents 'przydatne podczas podpięcia paska postępu
 If item.Size > oMailWaight Then
 'Debug.Print item.Subject & " " & item.Size & " " & oMailWaight
 item.Move destFolder
 End If
 Next
Set OlFolder = Nothing
Set OldestFolder = Nothing
End Sub

Domyślnie podpowiadanym przez mechanizm folderem jest folder „Backup” (lub dowolnie podany w wywołanym przez makro oknie), jednakże, jeśli nie chcemy a był on wcale 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.

Obkurczenie 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:

Prawy klawisz na Foldery osobiste/Właściwości/Zaawansowane/Kompaktuj