VBATools

Przeniesienie wydarzeń kalendarzowych do innego folderu

by on Feb.08, 2011, under Outlook, Porady

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:

OL_AutoArchiveCalendar

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

Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.

:, , , ,

Leave a Reply

Recently Active Members

Profile picture of vbatools
Profile picture of Karol Stilger
Profile picture of marcinmachalowski
Profile picture of Joanna Subik
Profile picture of Anorak
Profile picture of programistaaccess
Profile picture of piotrpawlik
Profile picture of Emil Wasilewski
Profile picture of kicekpicek
Profile picture of coldfusion
Profile picture of Gosia Borzęcka
Profile picture of lukaszch
Profile picture of itadministracja
Profile picture of farbenia
Profile picture of Łukasz Kałużny
Profile picture of kabzinski
Profile picture of rtynski
Profile picture of leszekbetlinski
Profile picture of Iv
Profile picture of Justyna Spychała