VBATools

Nawiązując do mechanizmu archiwizacji można wykonać kodem VBA podobną operację, bazując na innych elementach określonych datą utworzenia, lub modyfikacji obiektu, tematem lub innym elementem obiektu.

Standardowe przeniesienie wbudowanym mechanizmem jest dostępne pod postacią archiwum, w którym to można ustawić jedynie datę oraz wskazać docelowy plik pst:

Rys 1. Mechanizm archiwizacji folderu dostępny z poziomu właściwości folderu.

Poniższy kod pokazuje jak dokonać podobnej czynności kierując się parametrem utworzenia (można zmienić) oraz folderem docelowym (o ile mamy podpięty folder archiwum lub folder udostępniony innym pracownikom to wskazanie tego folderu nie jest problemem).

Aby osadzić kod VBA należy otworzyć developera (Alt+F11) i osadzić poniższy kod w module i uruchomić procedurę Alt+F8:

Option Explicit
Sub MoveCalItems2Folder()
'date mozna zapisać w formacie "YYYY-MM-DD", poniżej data dziś minus 128 dni.
Call move_calendar_items_by_creaction_date(Now - 128)
End Sub

Private Sub move_calendar_items_by_creaction_date(CreationTime As Date)
'MVP OShon from VBATools.pl
If IsDate(CreationTime) = False Then _
MsgBox "Aby procedura pobrała datę utworzenia obiektu należy określić jej granicę podając" & _
 " datę w formacie YYYY-DD-MM", vbExclamation, _
 " Informacja o błędzie VBATools.pl": Exit Sub

Dim oDestContactFolder As MAPIFolder, SourceFolder As MAPIFolder, x&: x = 0
Dim bExitFor As Boolean: bExitFor = False

 Do
 Set oDestContactFolder = Application.GetNamespace("MAPI").PickFolder
 If oDestContactFolder Is Nothing Then Exit Sub
 With oDestContactFolder
 If .DefaultMessageClass <> "IPM.Appointment" Then
 MsgBox "Przenesienie do folderu " & Chr(34) & .Name & Chr(34) & " nie jest możliwe." & vbCr _
 & "Wybierz lub utwórz i zaznacz folder kalendarza jako docelowe miejsce exportu!", _
 vbExclamation, " Informacja o błędzie VBATools.pl"
 Else
 bExitFor = True
 End If
 End With
 Loop While Not bExitFor

With Application.GetNamespace("MAPI")
 Set oDestContactFolder = .GetFolderFromID(oDestContactFolder.EntryID, oDestContactFolder.StoreID)
 Set SourceFolder = Application.ActiveExplorer.CurrentFolder
End With

With SourceFolder
 If .Name = oDestContactFolder.Name Then _
 MsgBox "Przenesienie z " & Chr(34) & .Name & Chr(34) & _
 " do folderu " & Chr(34) & oDestContactFolder.Name & Chr(34) & " nie jest możliwe!", _
 vbExclamation, " Informacja o błędzie VBATools.pl": Exit Sub

 For x = .Items.Count To 1 Step -1
 DoEvents
 Debug.Print .Items(x).Subject
 If Format(.Items(x).CreationTime, "Short Date") <= Format(CreationTime, "Short Date") Then
 Debug.Print "Export z " & .Name & " -> " & .Items(x).Subject & " " & _
 .Items(x).CreationTime & " -> " & oDestContactFolder
 .Items(x).Move oDestContactFolder
 End If
 Next
 Set oDestContactFolder = Nothing
 Set SourceFolder = Nothing
End With
End Sub

Należy jednak mieć na uwadze iż wydarzenie kalendarzowe w momencie jego utworzenia może posiadać określoną datę wydarzenia na XX dni naprzód, a w tedy może ono być również przeniesione .

Aby zastosować datę końca wydarzenia należy zamienić .Items(x).CreationTime na .Items(x).Start
lub dla daty modyfikacji .Items(x).LastModificationTime

(c) Shon Oskar – www.VBATools.pl