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.

 

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

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