
Przeniesienie wydarzeń z kalendarza do innego folderu z warunkami
Nawiązując do mechanizmu archiwizacji poczty podobną operację można wykonać za pomocą kodu VBA, dla innych elementów określonych datą ich utworzenia, modyfikacji, tematem lub innymi właściwościami.
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 go 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ć narzędzie developera (Alt+F11), osadzić poniższy kod w module i uruchomić procedurę Alt+F8:
Sub MoveCalItems2Folder() 'date mozna zapisać w formacie "YYYY-MM-DD" Call move_calendar_items_by_creaction_date(Now - 128) End Sub Private Sub move_calendar_items_by_creaction_date(ByVal CreationTime As Date) '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 oDestContactFolder = Application.GetNamespace("MAPI").PickFolder If oDestContactFolder Is Nothing Then Exit Sub With oDestContactFolder If .DefaultMessageClass <> "IPM.Appointment" Then MsgBox "Przenesienie do folderu ''" & .Name & _ "'' 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") oDestContactFolder = .GetFolderFromID(oDestContactFolder.EntryID, oDestContactFolder.StoreID) SourceFolder = Application.ActiveExplorer.CurrentFolder End With With SourceFolder If .Name = oDestContactFolder.Name Then _ MsgBox "Przenesienie z ''" & .Name & _ "'' do folderu ''" & oDestContactFolder.Name & "'' nie jest możliwe!", _ vbExclamation, " Informacja o błędzie VBATools.pl": Exit Sub Dim a As AppointmentItem a.LastModificationTime 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 oDestContactFolder = Nothing SourceFolder = Nothing End With End Sub
Należy jednak mieć na uwadze, iż wydarzenie w kalendarzu w momencie jego utworzenia może posiadać określoną datę końca wydarzenia na XX dni naprzód, a wtedy 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
MVP Shon Oskar – VBATools.pl
Jeśli masz pytania dot. tego artykułu zapraszam na Forum
Skonfiguruj swój pakiet dodatków do Excela, Worda, PowerPointa i Outlooka
© Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.