Microsoft Outlook troubleshooting

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: 
 
Archiwizacja folderu w Outlooku 
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.

Komentarze

Komentarze
OShon
OShon, VBATools.pl 2013-03-12 14:33:41
proszę traktować xhr jako chr (błąd edytora tego artykułu)