Widok spotkań z podfolderów programu Outlook na pasku zadań do wykonania

W programie Outlook można utworzyć podfoldery kalendarza, które dzięki np. narzędziu rozpowszechnionemu przez mechanizm Google możemy synchronizować z innymi użytkownikami. Jednakże terminy z podfolderów nie będą pokazywane na pasku zadań do wykonania. Użytkownik musi wtedy czekać na przypomnienia lub zaglądać nie tylko do poczty, ale także do osobnych folderów kalendarzy.

Główną przyczyną tego problemu jest prosta konfiguracja paska zadań. Nie pozwala ona na zdefiniowanie innego kalendarza, niż domyślnego (Rys.1.).

Rys.1. Opcje konfiguracji paska zadań.

Stajemy więc przed problemem utrzymania dwóch terminów (kopia w głównym folderze i oryginał w synchronizowanym podfolderze), albo rezygnacją z pokazywania obiektów w pasku zadań do wykonania i śledzenie wszystkich folderów.

Rozwiązaniem jest zastosowanie procedury VBA, która poza wykonaniem kopii obiektu doda kategorię o nazwie źródłowego podfoldera. Dzięki temu użytkownik będzie mógł sortować skopiowane przez procedurę terminy.

Wiemy, że terminy mogą się zmieniać. Można również tworzyć całkiem nowe, więc wypada aby mechanizm sprawdzał czy jest już taki termin - np. po temacie (i jeśli tak to go usunął), a następnie skopiował go ponownie z podfoldera do foldera głównego.

To da nam możliwość aktualizowania danych wydarzenia kalendarzowego w folderze głównym kalendarza, przy ustaleniu, że temat wydarzenia raz nadany się już nie zmieni.

Poniższą procedurę, należy umieścić w module środowiska VBA Outlooka [Alt+F11 Insert/module]  

Sub Kopia_do_Kalendarza()
    Dim Kalendarz As MAPIFolder, Ten_folder As MAPIFolder
    Dim aItems As AppointmentItem, objNewApp As Object
    Kalendarz = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
    Ten_folder = Application.ActiveExplorer.CurrentFolder
    If Ten_folder.Name = Kalendarz.Name Then Exit Sub
    For Each aItems In Ten_folder.Items
        Call FindKal(aItems.Subject)
        objNewApp = aItems.Copy
        objNewApp.Categories = Ten_folder.Name
        objNewApp.Move(Kalendarz)
    Next aItems
End Sub

Private Sub FindKal(ByVal sprawdz)
    Dim oApptFolder As MAPIFolder
    oApptFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
    Dim olApp As Items
    olApp = oApptFolder.Items

    sprawdz = """" & sprawdz & """"

    Dim oTask As AppointmentItem
    On Error GoTo Kal_wyjdz
    oTask = olApp.Find("[Subject] =" & sprawdz)

    While Not oTask Is Nothing
        DoEvents()
        oTask.Delete()
        oTask = olApp.FindNext()
    End While
Kal_wyjdz:
    oApptFolder = Nothing
    olApp = Nothing
    oTask = Nothing
End Sub

Wywołanie powyższej procedury jest realizowane na poziomie ustawienia kursora na kalendarzu (podfolderze), z jakiego się chce skopiować obiekty i uruchomienia procedury. Samo uruchomienie realizowane jest po przez skrót klawiszowy [Alt+F8] lub dzięki wcześniejszemu przypisaniu procedury do przycisku z paska szybkiego wybierania.

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.