VBATools

W Outlook można utworzyć subfoldery kalendarza, które dzięki np narzędziu rozpowszechnionemu przez mechanizm Googlea możemy synchronizować z zainteresowanymi. Wszystko było by fajnie, gdyby nie fakt, iż osadzone terminy z subfolderów nie będą pokazywać się na pasku zadań do wykonania. Zmusza to użytkownika aby liczył na przypomnienia lub zaglądał nie tylko do poczty ale do osobnych folderów kalendarzy.

Główną przyczyną tego problemu jest oszczędna w możliwości konfiguracja paska zadań. Nie pozwala ona na zdefiniowanie innego niż domyślny folder kalendarza (rys 1.).

Stajemy więc przed problemem utrzymania 2-ch terminów (kopia w głównym folderze i oryginał w synchronizowanym sub folderze), albo rezygnacja 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 subfolderu. Dzięki temu użytkownik będzie mógł sortować skopiowane przez procedurę terminy.

Wiemy iż terminy mogą się zmieniać/ewaluować oraz mogą być tworzone 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 z subfolderu do folderu głównego ponownie.
Da to możliwość przy ustaleniu iż “temat wydarzenia, raz nadany się nie zmieni”, aktualizowania danych wydarzenia kalendarzowego w folderze głównym kalendarza. Dodatkowo kopia terminu będzie miała wyłączone przypomnienie, co zapobiegnie przez duplikowaniem się komunikatów o zbliżającym się wydarzeniu.

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

Sub Kopia_do_Kalendarza()
'MVP OShon from VBAtools.pl
Dim Kalendarz As MAPIFolder, Ten_folder As MAPIFolder
Dim aItems As AppointmentItem, objNewApp As Object
Set Kalendarz = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
Set Ten_folder = Application.ActiveExplorer.CurrentFolder
If Ten_folder.DefaultMessageClass <> "IPM.Appointment" Then
 MsgBox "Przejdź do folderu subkalendarza i wywołaj procedurę ponownie!", _
 vbExclamation, "Informacja o błędzie - VBATools.pl"
 Exit Sub
End If
On Error GoTo koniec
If Ten_folder.Name = Kalendarz.Name Then Exit Sub
For Each aItems In Ten_folder.Items
 Call FindKal(aItems.Subject)
 Set objNewApp = aItems.Copy
 objNewApp.Categories = Ten_folder.Name
 objNewApp.ReminderSet = False
 objNewApp.Move Kalendarz
Next aItems
Exit Sub
koniec:
MsgBox Err.Number & vbCr & Err.Description, vbExclamation, _
 "Informacja o błędzie - VBATools.pl"
End Sub

Private Sub FindKal(sprawdz)
'MVP OShon fromo VBATools.pl
 Dim oApptFolder As MAPIFolder
 Set oApptFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
 Dim olApp As Items
 Set olApp = oApptFolder.Items

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

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

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

(c) Shon Oskar – www.VBATools.pl