Как автоматически объединить все встречи и встречи из всех календарей с помощью Outlook VBA

Если вы хотите всегда объединять все встречи и встречи из всех календарей в один календарь для удобной проверки, вы можете применить метод, представленный в этой статье.

Возможно, в вашем Outlook настроено много учетных записей электронной почты. В этом случае у вас должно быть много календарей в Outlook. Поэтому каждый раз, когда вы хотите проверить, сколько сегодня встреч, вам приходится переключаться на все календари. Будет немного хлопотно. Так почему бы вам не объединить их в один календарь? Далее мы представим фрагмент кода VBA, который может легко его реализовать.

Автоматическое объединение всех встреч и собраний из всех календарей

1. В самом начале запустите приложение Outlook.
2. После того, как вы войдете в главное окно Outlook, нажмите клавиши «Alt + F11».
3. Затем вы попадете в окно «Microsoft Visual Basic для приложений».
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. В конце концов, вы можетеtart вашей программе Outlook, чтобы активировать новый макрос.
9. Отныне каждый раз, когда любая новая встреча или встреча добавляется в календари не по умолчанию, они будут автоматически копироваться в календарь по умолчанию, как показано на следующем снимке экрана:

Удалить просроченные элементы из календаря вовремя

Как мы знаем, Outlook более подвержен различным ошибкам, когда почтовый ящик становится все больше и больше. Поэтому рекомендуется вовремя удалять из почтового ящика бесполезные предметы, такие как просроченные встречи и встречи. В то же время, лучше, если вы держите поблизости мощное средство для ремонта, например, DataNumen Outlook Repair. Он может восстановить Outlook вопросы, не нарушая пота.

Об авторе:

Ширли Чжан — эксперт по восстановлению данных в DataNumen, Inc., которая является мировым лидером в области технологий восстановления данных, включая sql восстановление и программные продукты для ремонта Outlook. Для получения дополнительной информации посетите www.datanumen.com