Calendar of birthdays and anniversaries of Outlook contacts

After switching from Google (Gmail, Contacts, Calendar) to MS Exchange and Outlook, the most I missed was the “Birthdays and Events of Contacts” calendar, in which the events of the same name were automatically created from the address book. The standard Outlook function of creating a birthday record when editing a contact did not suit me, since All new contacts with birthdays and anniversaries, as a rule, are created in a mobile phone account connected to Exchange via the ActiveSync protocol. And with this method of data entry, no calendar entries are created.

Therefore, the VBA script was written (since no free solution found on the Internet, I did not fit the functionality), which does the following:
- re-saves birth dates and anniversaries of all contacts of the address book (thus, the birthdays and anniversaries of contacts are created in the calendar by the native Outlook function);
- moves all records of such events from the standard calendar to the one specified by the user (so as not to litter the main calendar overloaded with entries);
- corrects the “Store as” contact entries (as you know, iOS and Android work incorrectly with this field in Microsoft Exchange accounts) as follows: if the First Name or Last Name fields contain any values, then Keep As will take the value “First Name”, otherwise - “Organization” (this is especially useful if you save the names of services and offices of any kind in the “Organization” field, not “First Name”, such as “Pizza Delivery”).

In order to earn such an algorithm, no additional software needs to be installed.
It takes only 2 actions: to allow execution of unsigned macros and copy the script itself through the clipboard (CTRL-C, CTRL-V) into Outlook.

To allow unsigned macros to run,
1. In Outlook, go to File -> Settings -> Trust Center -> Trust Center Settings:
')


2. Macro settings -> select “Notifications for all macros”:



The next step is to insert the body of the script itself (macro) into Outlook.

To do this, click on ALT-F11 in Outlook - go to the Microsoft Visual Basic for Applications editor -> in the “Project” section, select “ThisOutlookSession”:



And in the opened window we insert the script:

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("\\me@about.com\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 

Save, close the editor and return to Outlook.

All we have to do is execute this script. To do this, press ALT-F8, select "ThisOutlookSession.olRobot" and press the "Run" button:



In the process of the script, a dialog box will open with a suggestion to specify in which calendar to place the birthdays and anniversaries of the “Select Birthdays and Anniversaries Calendar folder by next step”:



Experienced users, pay attention to the different methods of obtaining primary information in the script body.

If you had incorrect records about such events in the main calendar - run this script a second time, it will correct them.

Now it’s enough to launch it by pressing ALT-F8 so that your calendar looks like candy.

Enjoy!