Как да обедините автоматично всички срещи и срещи от всички календари с Outlook VBA

Ако искате винаги да обединявате всички срещи и срещи от всички календари в един календар за удобна проверка, можете да приложите метода, представен в тази статия.

Може би имате много имейл акаунти, конфигурирани във вашия Outlook. В този случай трябва да имате много календари във вашия Outlook. Следователно всеки път, когато искате да проверите колко ангажименти има днес, трябва да превключите към всички календари. Ще бъде малко неприятно. Така че защо не ги обедините в един календар? По-долу ще изложим част от VBA код, който може да го реализира с лекота.

Автоматично обединяване на всички срещи и срещи от всички календари

1. В самото начало стартирайте приложението си Outlook.
2. След като влезете в главния прозорец на Outlook, натиснете клавишните бутони „Alt + F11“.
3. След това ще влезете в прозореца „Microsoft Visual Basic for Applications“.
4. След това трябва да намерите и отворите проекта „ThisOutlookSession“.
5. Впоследствие трябва да копирате и поставите следните VBA кодове в този прозорец на проекта.

'Here we take two calendars as an example - "Calendar A" & "Calendar B"
'You can add more as per your needs
Dim WithEvents objACalendarItems As Outlook.Items
Dim WithEvents objBCalendarItems As Outlook.Items
Dim objDefaultCalendar As Outlook.Folder
 
Private Sub Application_Startup()
    Set objACalendarItems = Application.Session.folders("File A").folders("Calendar").Items
    Set objBCalendarItems = Application.Session.folders("File B").folders("Calendar").Items

    'Here we merge into the default calendar
    Set objDefaultCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
End Sub
 
Private Sub objACalendarItems_ItemAdd(ByVal Item As Object)
    Call CopyToDefaultCalendar(Item)
End Sub

Private Sub objBCalendarItems_ItemAdd(ByVal Item As Object)
    Call CopyToDefaultCalendar(Item)
End Sub

Private Sub CopyToDefaultCalendar(ByVal objItem As Object)
    Dim objCopiedAppointment As Outlook.AppointmentItem
    Dim objMoviedAppointment As Outlook.AppointmentItem
    Dim strPSTFileName As String
 
    Set objCopiedAppointment = objItem.Copy
    Set objMoviedAppointment = objCopiedAppointment.Move(objDefaultCalendar)
 
    strPSTFileName = objItem.parent.parent.Name
 
    'Tag the source of the copied appointments
    objMoviedAppointment.Categories = "From " & strPSTFileName
    objMoviedAppointment.Save
    'If want to delete it from the original calendar, add the following line:
    'objItem.Delete
End Sub

6. След това трябва да присвоите цифров сертификат на текущия макрос.
7. По-късно отидете на „настройки на макроси“, за да разрешите цифрово подписаните макроси.
8. В крайна сметка можете да рестартирате програмата Outlook, за да активирате новия макрос.
9. Отсега нататък всеки път, когато се добави нова среща или среща в календарите, които не са по подразбиране, те ще бъдат автоматично копирани в календара по подразбиране, като следната екранна снимка:

Премахнете навреме просрочените елементи от календара

Както знаем, Outlook е по-склонен към различни грешки, когато пощенската кутия става все по-голяма. Поради това се препоръчва навреме да премахнете безполезни елементи от пощенската кутия, като просрочени срещи и срещи. Междувременно е по-добре да държите наблизо мощен инструмент за ремонт, като напр DataNumen Outlook Repair, То може ремонт на Outlook проблеми, без да се изпотявате.

Въведение на автора:

Шърли Джанг е експерт по възстановяване на данни в DataNumen, Inc., която е световен лидер в технологиите за възстановяване на данни, включително sql възстановяване и outlook софтуерни продукти за ремонт. За повече информация посетете WWW.datanumen.com