Календарь дней рождений и юбилеев контактов Outlook

После перехода с Google (Gmail, Контакты, Календарь) на MS Exchange и Outlook мне больше всего не хватало календаря «Дни рождения и мероприятия контактов», в котором автоматически создавались одноименные события из адресной книги. Стандартная функция Outlook создания записи о дне рождения при редактировании контакта меня не устроила, т.к. все новые контакты с датами рождений и юбилеями, как правило, создаются в мобильном телефоне аккаунта, подключенного к Exchange по протоколу ActiveSync. А при таком способе ввода данных никакие записи в календаре не создаются.

Поэтому был написан VBA скрипт (т.к. ни одно бесплатное решение, найденное в интернете, мне не подошло по функционалу), который делает следующее:
— пересохраняет даты рождений и юбилеи всех контактов адресной книги (таким образом, нативной функцией Outlook в основом календаре создаются записи о днях рождениях и юбилеях контактов);
— перемещает все записи о таких событиях из стандартного календаря в указанный пользователем (чтобы не засор��ть и без того перегруженный записями основной календарь);
— исправляет записи контактов «Хранить как» (как известно, iOS и Android некорректно работают с этим полем в аккаунтах Microsoft Exchange) следующим образом: если поле «Имя» или «Фамилия» содержат какие-то значения, то «Хранить как» примет значение «Имя Фамилия», в противном случае — «Организация» (это особенно полезно, если сохраняешь названия служб и всякого рода контор в поле «Организация», а не «Имя», как, например, «Доставка Пиццы»).

Для того, чтобы заработал такой алгоритм, никакой дополнительный софт не нужно устанавливать.
Нужно выполнить всего-лишь 2 действия: разрешить выполнение неподписанных макросов и скопировать сам скрипт через буфер обмена (CTRL-C, CTRL-V) в Outlook.

Чтобы разрешить выполнение неподписанных макросов,
1. В Outlook войдите в Файл -> Параметры -> Центр управления безопасностью -> Параметры центра управления безопасностью:



2. Параметры макросов -> выбрать «Уведомления для всех макросов»:



Следующим шагом нужно вставить тело самого скрипта (макроса) в Outlook.

Для этого в Outlook нажимаем ALT-F11 — попадаем в редактор Microsoft Visual Basic for Applications -> в разделе «Project» выбираем «ThisOutlookSession»:



И в открывшееся окно вставляем скрипт:

Sub olRobot()
' Outlook VBA script by Sergii Vakula
' Auto generation the Birthdays and Anniversaries appointments of all Contact folders to a specific calendar
' Auto changing Contact's FileAs fields: FullName for humans, CompanyName for companies

    Dim objOL As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim objItems As Outlook.Items
    Dim obj As Object
    Set objOL = CreateObject("Outlook.Application")
    Set objNS = objOL.GetNamespace("MAPI")

    On Error Resume Next

  ' *****************************************************************************************************
  ' *** STAGE 1: Rebuilding Contact's Birthdays and Anniversaries to the main calendar, fixing FileAs ***
  ' *****************************************************************************************************

    Dim Report As String
    Dim mySession As Outlook.NameSpace
    Dim myFolder As Outlook.Folder
    Set mySession = Application.Session

  ' Method 1: Ask for Contact folder
    'MsgBox ("Select Contact folder by next step...")
    'Call ContactsFolders(Session.PickFolder, Report)

  ' Method 2: Use default Contact folder and all subfolders
    'Call ContactsFolders(objNS.GetDefaultFolder(olFolderContacts), Report)

  ' Method 3: Use all Contact folders
    For Each myFolder In mySession.Folders
        Call ContactsFolders(myFolder, Report)
    Next

  ' ***************************************************************************************
  ' *** STAGE 2: Moving Birthdays and Anniversaries appointments to a specific calendar ***
  ' ***************************************************************************************

    Dim objCalendar As Outlook.AppointmentItem
    Dim objCalendarFolder As Outlook.MAPIFolder
    Dim cAppt As AppointmentItem
    Dim moveCal As AppointmentItem
    Dim pattern As RecurrencePattern
    Set objCalendarFolder = objNS.GetDefaultFolder(olFolderCalendar)
    bodyMessage = "This is autocreated appointment"

  ' Method 1: Ask for specific calendar folder for birthdays and anniversaries
    MsgBox ("Select Birthdays and Anniversaries Calendar folder by next step...")
    Set newCalFolder = Session.PickFolder

  ' Method 2: Use pre-assigned calendar folder for birthdays and anniversaries
    'Set newCalFolder = GetFolderPath("display name in folder list\Calendar\Birthdays and Anniversaries")
    'Set newCalFolder = GetFolderPath("\\[e-mail]\Calendar\Birthdays and Anniversaries")

    For i = newCalFolder.Items.Count To 1 Step -1
        Set obj = newCalFolder.Items(i)
        If obj.Class = olAppointment And _
            obj.GetRecurrencePattern.RecurrenceType = olRecursYearly And _
            obj.AllDayEvent And _
            obj.Body = bodyMessage Then
                Set objCalendar = obj
                objCalendar.Delete
        End If
        Err.Clear
    Next

    For i = objCalendarFolder.Items.Count To 1 Step -1
        Set obj = objCalendarFolder.Items(i)
        If obj.Class = olAppointment And _
            obj.GetRecurrencePattern.RecurrenceType = olRecursYearly And _
            obj.AllDayEvent And _
            (Right(obj.Subject, 11) = "'s Birthday" Or Right(obj.Subject, 14) = "'s Anniversary" Or _
            Right(obj.Subject, 13) = "День рождения" Or Right(obj.Subject, 9) = "Годовщина") Then

            Set objCalendar = obj
            Set cAppt = Application.CreateItem(olAppointmentItem)

            With cAppt
                .Subject = objCalendar.Subject
                .Start = objCalendar.Start
                .Duration = objCalendar.Duration
                .AllDayEvent = True
                .Body = bodyMessage
                .ReminderSet = False
                .BusyStatus = olFree
            End With

            Set pattern = cAppt.GetRecurrencePattern
            pattern.RecurrenceType = olRecursYearly
            cAppt.Save

            objCalendar.Delete

            Set moveCal = cAppt.Move(newCalFolder)
            'moveCal.Categories = "moved"
            moveCal.Save

        End If
        Err.Clear
    Next

    Set objOL = Nothing
    Set objNS = Nothing
    Set obj = Nothing
    Set objContact = Nothing
    Set objItems = Nothing
    Set objCalendar = Nothing
    Set objCalendarFolder = Nothing
    Set cAppt = Nothing
    Set moveCal = Nothing
    Set pattern = Nothing
    Set mySession = Nothing
    Set myFolder = Nothing

    MsgBox ("Completed!" & vbCrLf & vbCrLf & "All Contact's FileAs were fixed." & vbCrLf & "All Birthdays and Anniversaries appointments were re-created." & vbCrLf & vbCrLf & "Contact folders that been processed:" & vbCrLf & Report & vbCrLf & "Calendar for Birhdays and Anniversaries:" & vbCrLf & newCalFolder.FolderPath & vbCrLf & vbCrLf & "Have a nice day!")

End Sub

Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer
    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    Set GetFolderPath = oFolder
    Exit Function
GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function


Private Sub ContactsFolders(CurrentFolder As Outlook.Folder, Report As String)
    Dim objItems As Outlook.Items
    Dim obj As Object
    Dim objContact As Outlook.ContactItem
    Dim strFileAs As String
    Dim SubFolder As Outlook.Folder
    Dim SubFolders As Outlook.Folders
    Set SubFolders = CurrentFolder.Folders
    If CurrentFolder.DefaultItemType = 2 Then
        Report = Report & CurrentFolder.FolderPath & vbCrLf
        Set objItems = CurrentFolder.Items
        For Each obj In objItems
            If obj.Class = olContact Then
                Set objContact = obj

                With objContact
                    .Display

                    If .FullName = "" Then
                        strFileAs = .CompanyName
                    Else
                        strFileAs = .FullName
                    End If

                    .FileAs = strFileAs

                    mybirthday = .Birthday
                    myanniversary = .Anniversary
                    .Birthday = Now
                    .Anniversary = Now
                    .Birthday = mybirthday
                    .Anniversary = myanniversary

                    .Save
                    .Close 0
                End With

            End If
            Err.Clear
        Next

    End If

    For Each SubFolder In SubFolders
        Call ContactsFolders(SubFolder, Report)
    Next

    Set SubFolder = Nothing
    Set SubFolders = Nothing

End Sub

Сохраняем, закрываем редактор и возвращаемся в Outlook.

Все, что нам остается — выполнить этот скрипт. Для этого нажимаем ALT-F8, выбираем «ThisOutlookSession.olRobot» и нажимаем кнопку «Выполнить»:



В процессе работы скрипта откроется диалоговое окно с предложением указать, в какой именно календарь помещать записи о днях рождений и юбилеях контактов «Select Birthdays and Anniversaries Calendar folder by next step»:



Опытные пользователи, обратите внимание на разные методы получения первичной информации в теле скрипта.

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

Теперь достаточно запустить его нажатием ALT-F8 для того, чтобы ваш календарь выглядел как конфетка.

Enjoy!