Create and/or update Outlook contacts from Excel

When you have a good overview of all your contact details in an Excel file, it can be useful to export these towards Outlook (eg to allow automatic synchronization towards your mobile). When including contact pictures, the look and feel of Outlook and your mobile increases a lot by immediately showing the related pictures when receiving a mail or call.

Since the contact details can change over time, I created the Excel macro below to update existing contacts and create the non existing contact within Outlook, including all available details of the contact.

Using a ‘Reference’ sheet, in which the columns are references using a named cell, it’s easy to retrieve the contact details from the right column, while still being able to easily change the data or order. The data is retrieved using the Cells.Range option, eg: Sheets(sheetName).Cells(i, Sheets("References").Range("columnname").Value)

In order to make sure the same contact is not added multiple times, the contact is first retrieved from the available Outlook contacts using the olFolder.Item.Restrict(…filter…) option based on the email address of the contact.

Since I load the contact details from a DB using a linked Query within Excel, I also refresh the query data before performing the migration from Excel to Outlook.

All details can be found in the macro source below and the example Excel file (including the macro).

'Developed by myT, http://myTselection.blogspot.com
Option Explicit


Public Sub RefreshQueries()

  Dim wks As Worksheet
  Dim qt As QueryTable
  Dim lo As ListObject

  For Each wks In Worksheets
    For Each qt In wks.QueryTables
        qt.Refresh BackgroundQuery:=False
    Next qt

    For Each lo In wks.ListObjects
        lo.QueryTable.Refresh BackgroundQuery:=False
    Next lo

  Next wks

  Set qt = Nothing
  Set wks = Nothing
End Sub
'http://www.globaliconnect.com/excel/index.php?option=com_content&view=article&id=167:import-contacts-from-excel-to-outlook-automate-in-vba&catid=79&Itemid=475



Sub ExcelWorksheetDataAddToOutlookContacts()
    'Automating Outlook from Excel: This example uses the Items.Add Method to export data from an Excel Worksheet to the default Contacts folder.
    'Automate Outlook from Excel, using Late Binding. You need not add a reference to the Outlook library in Excel (your host application), in this case you will not be able to use the Outlook's predefined constants and will need to replace them by their numerical values in your code.
    
    
    
    Dim oApplOutlook As Object
    Dim oNsOutlook As Object
    Dim oCFolder As Object
    Dim oDelFolder As Object
    Dim oCItem As Object
    'Dim olItems As Outlook.Items
    Dim olItems As Object
    'Dim olContactItem As contactItem
    Dim olContactItem As Object
    Dim oDelItems As Object
    Dim lLastRow As Long, i As Long, n As Long, c As Long
    Dim firstRowToProcess As Integer, emailColumn As Integer, pictureColumn As Integer, processedColumn As Integer, itemsFound As Integer
    Dim sheetName As String, fullFilePath As String
    Dim updateExistingContacts As Boolean
    
    
    RefreshQueries
    
    'Config:
    sheetName = "Contacts"
    firstRowToProcess = 2
    updateExistingContacts = False
    
    updateExistingContacts = MsgBox("Update and overwrite fields of existing contacts? Pictures will always be updated. (Existing notes will be appended, not overwritten)", vbYesNo, "Overwrite")
    
    
   Application.ScreenUpdating = False
    ' turns off screen updating
    Application.DisplayStatusBar = True
    ' makes sure that the statusbar is visible
    Application.StatusBar = "Preparing export contacts to Outlook"
    
    'determine last data row in the worksheet:
    lLastRow = Sheets(sheetName).Cells(Rows.Count, "A").End(xlUp).Row
    
    'Create a new instance of the Outlook application, if an existing Outlook object is not available.
    'Set the Application object as follows:
    On Error Resume Next
    Set oApplOutlook = GetObject(, "Outlook.Application")
    'if an instance of an existing Outlook object is not available, an error will occur (Err.Number = 0 means no error):
    If Err.Number <> 0 Then
        Set oApplOutlook = CreateObject("Outlook.Application")
    End If
    'disable error handling:
    On Error GoTo 0
    
    'use the GetNameSpace method to instantiate (ie. create an instance) a NameSpace object variable, to access existing Outlook items. Set the NameSpace object as follows:
    Set oNsOutlook = oApplOutlook.GetNamespace("MAPI")
    
    '----------------------------
    
    'Empty the Deleted Items folder in Outlook so that when you quit the Outlook application you bypass the prompt: Are you sure you want to permanently delete all the items and subfolders in the "Deleted Items" folder?
    
    'set the default Deleted Items folder:
'    'The numerical value of olFolderDeletedItems is 3. The following code has replaced the Outlook's built-in constant olFolderDeletedItems by its numerical value 3.
'    Set oDelFolder = oNsOutlook.GetDefaultFolder(3)
'    'set the items collection:
'    Set oDelItems = oDelFolder.Items
'
'    'determine number of items in the collection:
'    c = oDelItems.Count
'    'start deleting from the last item:
'    For n = c To 1 Step -1
'        oDelItems(n).Delete
'    Next n
'
    '----------------------------
    
    'set reference to the default Contact Items folder:
    'The numerical value of olFolderContacts is 10. The following code has replaced the Outlook's built-in constant olFolderContacts by its numerical value 10.
    Set oCFolder = oNsOutlook.GetDefaultFolder(10)
'    Set olItems = oCFolder.Items.Restrict("[MessageClass]='IPM.Contact'")
    
    'Find contact to update, if not found add a new contact item
    
    
    'post each row's data on a separate contact item form:
    For i = firstRowToProcess To lLastRow
    'restrict info: https://msdn.microsoft.com/en-us/vba/outlook-vba/articles/items-restrict-method-outlook
    'folder items info: https://msdn.microsoft.com/en-us/vba/outlook-vba/articles/folder-items-property-outlook
        Set olItems = oCFolder.Items.Restrict("[MessageClass]='IPM.Contact' And [Email1Address] = '" & Sheets(sheetName).Cells(i, Sheets("References").Range("email").Value) & "'")
        
        itemsFound = 0
        For Each olContactItem In olItems
            
            Application.StatusBar = "Updating Outlook contact " + olContactItem.FullName & ", " & Sheets(sheetName).Cells(i, Sheets("References").Range("pnr").Value)
            'matching contact found in Outlook and Excel
			'web pictures should be stored in a local folder
            fullFilePath = Replace(Sheets(sheetName).Cells(i, Sheets("References").Range("pictureurl").Value), "http://someimageurl", "C:\Users\username\Documents\Pictures\profilephotos\")
            If FileExists(fullFilePath) Then
                olContactItem.AddPicture (fullFilePath)
            Else
                'MsgBox ("Missing picture: " + fullFilePath + ", for member: " + olContactItem.firstName + " " + olContactItem.lastname)
                Debug.Print ("Missing picture: " & fullFilePath & ", for member: " & olContactItem.firstName & " " & olContactItem.lastName)
            End If
            If updateExistingContacts = True Then
                With olContactItem
                    'update existing contact fields https://msdn.microsoft.com/en-us/library/microsoft.office.interop.outlook._contactitem_properties.aspx
                    .firstName = Sheets(sheetName).Cells(i, Sheets("References").Range("first_name").Value)
                    .lastName = Sheets(sheetName).Cells(i, Sheets("References").Range("last_name").Value)
                    If (Sheets(sheetName).Cells(i, Sheets("References").Range("birthdate").Value) <> "") Then
                        .Birthday = DateValue(Sheets(sheetName).Cells(i, Sheets("References").Range("birthdate").Value))
                    End If
                    .BusinessAddressStreet = "BusinessStreet 100"
                    .BusinessAddressCity = "BusinessCity"
                    .BusinessAddressCountry = "BusinessCountry"
                    .BusinessAddressPostalCode = "BusinessPostal"
                    .BusinessHomePage = "http://www.company.com"
                    'do not remove or duplicate existing categories, set some desired category when not yet set
                    If (InStr(.Categories, "Business") = 0) Then
                        .Categories = .Categories & ",Business"
                    End If
                    .CompanyName = "Company"
                    .Email1DisplayName = Sheets(sheetName).Cells(i, Sheets("References").Range("email").Value)
                    .FullName = Sheets(sheetName).Cells(i, Sheets("References").Range("first_name").Value) & " " & Sheets(sheetName).Cells(i, Sheets("References").Range("last_name").Value)
                    .FileAs = Sheets(sheetName).Cells(i, Sheets("References").Range("first_name").Value) & " " & Sheets(sheetName).Cells(i, Sheets("References").Range("last_name").Value)
                    '.gender = Sheets(sheetName).Cells(i, Sheets("References").Range("gender").Value)
'                    If (Sheets(sheetName).Cells(i, Sheets("References").Range("gender").Value) = "M") Then
'                        .gender = Microsoft.Office.Interop.Outlook.OlGender.olMale
'                    ElseIf (Sheets(sheetName).Cells(i, Sheets("References").Range("gender").Value) = "F") Then
'                        .gender = Microsoft.Office.Interop.Outlook.OlGender.olFemale
'                    Else
'                        .gender = Microsoft.Office.Interop.Outlook.OlGender.olUnspecified
'                    End If
                    .HomeAddressCity = Sheets(sheetName).Cells(i, Sheets("References").Range("city").Value)
                    .HomeAddressCountry = "DefaultCountry"
                    .HomeAddressPostalCode = Sheets(sheetName).Cells(i, Sheets("References").Range("postcode").Value)
                    .HomeAddressStreet = Sheets(sheetName).Cells(i, Sheets("References").Range("street").Value) & " " & Sheets(sheetName).Cells(i, Sheets("References").Range("street_number").Value)
                    .JobTitle = Sheets(sheetName).Cells(i, Sheets("References").Range("current_function").Value)
                    '.Language = Sheets(sheetName).Cells(i, Sheets("References").Range("speaking_language_info_list").Value)
                    .MobileTelephoneNumber = Sheets(sheetName).Cells(i, Sheets("References").Range("mobile").Value)
                    .BusinessTelephoneNumber = Sheets(sheetName).Cells(i, Sheets("References").Range("phone").Value)
                    .BusinessFaxNumber = Sheets(sheetName).Cells(i, Sheets("References").Range("fax").Value)
                    .Department = Sheets(sheetName).Cells(i, Sheets("References").Range("division").Value)
                    .ManagerName = Sheets(sheetName).Cells(i, Sheets("References").Range("manager").Value)
                    .WebPage = "http://www.company.com"
                    If (InStr(.body, "Staff number: ") = 0) Then
                        .body = "Staff number: " & Sheets(sheetName).Cells(i, Sheets("References").Range("pnr").Value) & vbCrLf
                        .body = .body & "Recruitment date: " & Sheets(sheetName).Cells(i, Sheets("References").Range("recruitment_date").Value) & vbCrLf
                        .body = .body & "Education: " & Sheets(sheetName).Cells(i, Sheets("References").Range("educations").Value) & vbCrLf
                        .body = .body & "Languages: " & Sheets(sheetName).Cells(i, Sheets("References").Range("speaking_language_info_list").Value) & vbCrLf
                        .body = .body & "Specialty skills: " & Sheets(sheetName).Cells(i, Sheets("References").Range("specialty_skills").Value) & vbCrLf
'                    Else
' keeps original body note, but duplicates all data if run mulitple times
'                        originalBody = .body
'                        .body = "Staff number: " & Sheets(sheetName).Cells(i, Sheets("References").Range("pnr").Value) & vbCrLf
'                        .body = .body & "Recruitment date: " & Sheets(sheetName).Cells(i, Sheets("References").Range("recruitment_date").Value) & vbCrLf
'                        .body = .body & "Education: " & Sheets(sheetName).Cells(i, Sheets("References").Range("educations").Value) & vbCrLf
'                        .body = .body & "Languages: " & Sheets(sheetName).Cells(i, Sheets("References").Range("speaking_language_info_list").Value) & vbCrLf
'                        .body = .body & "Specialty skills: " & Sheets(sheetName).Cells(i, Sheets("References").Range("specialty_skills").Value) & vbCrLf
'                        .body = .body & vbCrLf & originalBody
                    End If
                End With
                                        
            End If
            Sheets(sheetName).Cells(i, Sheets("References").Range("processed").Value).Value = "OK"
            olContactItem.Save
            itemsFound = itemsFound + 1
        Next
        
        If itemsFound = 0 Then
            Application.StatusBar = "Adding Outlook contact " & Sheets(sheetName).Cells(i, Sheets("References").Range("first_name").Value) & " " & Sheets(sheetName).Cells(i, Sheets("References").Range("last_name").Value) & ", " & Sheets(sheetName).Cells(i, Sheets("References").Range("pnr").Value)
            'Using the Items.Add Method to create a new Outlook contact item in the default Contacts folder.
            Set oCItem = oCFolder.Items.Add
            'display the new contact item form:
            'oCItem.Display
            'set properties of the new contact item:
            With oCItem
                    'update existing contact fields https://msdn.microsoft.com/en-us/library/microsoft.office.interop.outlook._contactitem_properties.aspx
                    .firstName = Sheets(sheetName).Cells(i, Sheets("References").Range("first_name").Value)
                    .lastName = Sheets(sheetName).Cells(i, Sheets("References").Range("last_name").Value)
                    If (Sheets(sheetName).Cells(i, Sheets("References").Range("birthdate").Value) <> "") Then
                        .Birthday = DateValue(Sheets(sheetName).Cells(i, Sheets("References").Range("birthdate").Value))
                    End If
                    .BusinessAddressStreet = "BusinessStreet 100"
                    .BusinessAddressCity = "BusinessCity"
                    .BusinessAddressCountry = "BusinessCountry"
                    .BusinessAddressPostalCode = "BusinessPostal"
                    .BusinessHomePage = "http://www.company.com"
                    'do not remove or duplicate existing categories, set some desired category when not yet set
                    If (InStr(.Categories, "Business") = 0) Then
                        .Categories = .Categories & ",Business"
                    End If
                    .CompanyName = "Company"
                    .Email1DisplayName = Sheets(sheetName).Cells(i, Sheets("References").Range("email").Value)
                    .FullName = Sheets(sheetName).Cells(i, Sheets("References").Range("first_name").Value) & " " & Sheets(sheetName).Cells(i, Sheets("References").Range("last_name").Value)
                    .FileAs = Sheets(sheetName).Cells(i, Sheets("References").Range("first_name").Value) & " " & Sheets(sheetName).Cells(i, Sheets("References").Range("last_name").Value)
                    '.gender = Sheets(sheetName).Cells(i, Sheets("References").Range("gender").Value)
'                    If (Sheets(sheetName).Cells(i, Sheets("References").Range("gender").Value) = "M") Then
'                        .gender = Microsoft.Office.Interop.Outlook.OlGender.olMale
'                    ElseIf (Sheets(sheetName).Cells(i, Sheets("References").Range("gender").Value) = "F") Then
'                        .gender = Microsoft.Office.Interop.Outlook.OlGender.olFemale
'                    Else
'                        .gender = Microsoft.Office.Interop.Outlook.OlGender.olUnspecified
'                    End If
                    .HomeAddressCity = Sheets(sheetName).Cells(i, Sheets("References").Range("city").Value)
                    .HomeAddressCountry = "DefaultCountry"
                    .HomeAddressPostalCode = Sheets(sheetName).Cells(i, Sheets("References").Range("postcode").Value)
                    .HomeAddressStreet = Sheets(sheetName).Cells(i, Sheets("References").Range("street").Value) & " " & Sheets(sheetName).Cells(i, Sheets("References").Range("street_number").Value)
                    .JobTitle = Sheets(sheetName).Cells(i, Sheets("References").Range("current_function").Value)
                    '.Language = Sheets(sheetName).Cells(i, Sheets("References").Range("speaking_language_info_list").Value)
                    .MobileTelephoneNumber = Sheets(sheetName).Cells(i, Sheets("References").Range("mobile").Value)
                    .BusinessTelephoneNumber = Sheets(sheetName).Cells(i, Sheets("References").Range("phone").Value)
                    .BusinessFaxNumber = Sheets(sheetName).Cells(i, Sheets("References").Range("fax").Value)
                    .Department = Sheets(sheetName).Cells(i, Sheets("References").Range("division").Value)
                    .ManagerName = Sheets(sheetName).Cells(i, Sheets("References").Range("manager").Value)
                    .WebPage = "http://www.company.com"
                    If (InStr(.body, "Staff number: ") = 0) Then
                        .body = "Staff number: " & Sheets(sheetName).Cells(i, Sheets("References").Range("pnr").Value) & vbCrLf
                        .body = .body & "Recruitment date: " & Sheets(sheetName).Cells(i, Sheets("References").Range("recruitment_date").Value) & vbCrLf
                        .body = .body & "Education: " & Sheets(sheetName).Cells(i, Sheets("References").Range("educations").Value) & vbCrLf
                        .body = .body & "Languages: " & Sheets(sheetName).Cells(i, Sheets("References").Range("speaking_language_info_list").Value) & vbCrLf
                        .body = .body & "Specialty skills: " & Sheets(sheetName).Cells(i, Sheets("References").Range("specialty_skills").Value) & vbCrLf
                    End If
            End With
                
                'mark as done
                Sheets(sheetName).Cells(i, Sheets("References").Range("processed").Value).Value = "OK"
            fullFilePath = Replace(Sheets(sheetName).Cells(i, Sheets("References").Range("pictureurl").Value), "http://someimageurl", "C:\Users\username\Documents\Pictures\profilephotos\")
            If FileExists(fullFilePath) Then
                oCItem.AddPicture (fullFilePath)
            Else
                'MsgBox ("Missing picture: " + fullFilePath + ", for member: " + oCItem.firstName + " " + oCItem.lastname)
                Debug.Print ("Missing picture: " & fullFilePath + ", for member: " & oCItem.firstName & " " & oCItem.lastName)
            End If
            'close the new contact item form after saving:
            'The numerical value of olSave is 0. The following code has replaced the Outlook's built-in constant olSave by its numerical value 0.
            oCItem.Close 0
        End If
    Next i
    
    'quit the Oulook application:
    oApplOutlook.Quit
    
    Application.StatusBar = "Outlook " & lLastRow & " contacts exported"
    Application.ScreenUpdating = True
    
    'clear the variables:
    Set oApplOutlook = Nothing
    Set oNsOutlook = Nothing
    Set oCFolder = Nothing
    Set oDelFolder = Nothing
    Set oCItem = Nothing
    Set oDelItems = Nothing
    Set olContactItem = Nothing
    Set olItems = Nothing
    
    MsgBox "Successfully Exported Worksheet Data to the Default Outlook Contacts Folder."
    
     

End Sub

Function FileExists(fullFileName As String) As Boolean
    FileExists = VBA.Len(VBA.Dir(fullFileName)) > 0
End Function

If This Than That – Cloud service orchestration

IFTTT and other (Microsoft Flow, Zapier, Integromat) easily enable anyone to combine many cloud services for task automation.

IFTTT is free and integrates many public cloud services, but it might seem limited in the combinations that can be created with it. Nevertheless I was surprised to see some nice examples that allow smart integration.

Control lights with planning:

I wanted to control my lights around the house, using a easy to manage planning (could be used to control central heating too). By combining the Google Calendar services and eWeLink IoT services, this was very easy and cheap, since only a Sonoff wifi relay had to be bought.

Within Google Calendar, I created a new calendar ‘Light-control’ with daily repeating events every evening to turn on the lights. Giving it a nice yellow color makes it very easy to get a clear overview.

Within IFTTT add a new applet with ‘if’ trigger Google Calendar ‘Any event starts’. The ‘then’ trigger can be set to eWeLink to switch on your Sonoff channel. Similar, another IFTTT applet can be created triggered on ‘Any event ends’ to switch off you Sonoff channel via the eWeLink Smart Home service.

By just updating your calendar events you can now very easily manage your IoT device planning. You can even ‘invite’ your lights to participate in a ‘meeting'. Just enable the Google Calendar option ‘Auto accept invites’ and put your calendar id (eg 123456789abcdefg@group.calendar.google.com) as a guest for your meeting and the light will switch on and off for your planned event.

Complex combinations

Sometime the one-on-one link that can be used for the service orchestration within IFTTT can be too limited. To enable complex combinations, apilio.io or switchur can be used.

As an example, using apilio.io, I wanted to be warned if frost would be expected tomorrow, to make sure I would protect my car windshield in time. But I want to get warned when arriving at home in the evening, to make sure I get notified while still in my car, while by default the Weather Underground service would provide the Weather forecast of tomorrow, early in the mornings.

First create you apilio.io account and register your IFTTT WebHooks settings.

Next, within apilio.io, I create 3 boolean variables:

1. arriving_home
2. evening
3. frost_tomorrow

For each of these boolean variables, URL’s will be provided by apilio to set the value of the boolean to true or false using a unique webservice url.

Next, within IFTTT I created several applets:

1. IFTTT Location service:

• applet if ‘You enter an area’ then call the webhook url to set to ‘true’ the ‘arriving_home’ boolean
• applet if ‘You exit an area’ then call the webhook url to set to ‘false’ the ‘arriving_home’ booelan

2. IFTTT Date Time service:

• applet if 17:00 (5pm) then call the webhook url to set to ‘true’ the ‘evening’ boolean
• applet if 00:00 (0am) then call the webhook url to set to ‘false’ the ‘evening’ boolean

3. IFTTT Weather Underground service:

• applet if ‘Tomorrow’s low drops below’ 4°C then call the webhook url to set to ‘true’ the ‘frost_tomorrow’ boolean
• applet if ‘Tomorrow’s forecast calls for’ snow then call the webhook url to set to ‘true’ the ‘frost_tomorrow’ boolean
• Since no trigger is available to set the boolean value ‘frost_tomorrow’ back on false, we will include in the apilio condition this value needs to be ‘changed’ at least within the last 24h. Weather Underground will typically provide the next day forecast at 7am.

4. IFTTT Webhook service (callback):

• This webhook applet will be called by apilio to trigger a desired action when all conditions are met. The name of the applet is important, as it will need to be registered within apilio in order to call the right applet. If the applet is called, then a desired action can be triggered, eg showing a notification on your mobile.

Again within apilio.io, I created 3 conditions:

1. at_home_condition –> linked to value of variable ‘arriving_home’
2. evening_condition –> linked to value of variable ‘evening’
3. frost_tomorrow_condition –> linked to value of variable ‘frost_tomorrow’ including the timestamp restriction the value has to be modified within 72000seconds.

Now, within apilio.io, a logic block can be created, linked to the 3 conditions created above. When all conditions are met, the IFTTT webhook can be called by apilio. The name of the IFTTT webhook callback applet created before needs to be provided. Enable the ‘Automatic evaluation’ to evaluate the conditions defined in the logic block whenever any of the condition values changes.

To test the complete setup, the different apilio URL’s to set the boolean values can be called manually to see if the resulting IFTTT webhook appled is called as soon as all conditions are met.

In this example, only boolean variables have been used, which makes the link between a variable and the condition within apilio very straightforward. But whenever needed string or numeric variables can be defined as well. The conditions related to these variables can get more complex evaluations, such as containing some values or smaller, equal, etc.

Feel free to comment or add extra ideas of interesting combinations that would be possible.

Update 19/12/2019: Since Apilio.io will soon become a paid only service, we're looking into moving all the logic to an alternative platform. sequematic.com and switchur are possible options.

Uodate 12/05/2021: As IFTTT started to ask much more money to their connected manufacturers and even high monthly fees to their users on top, I decided to completely move away from IFTTT. Too bad for the nice community they build up, but alternatives seem to have become very mature in the mean time. I wrote a long detailed post about my move towards the excellent free Home Assistant alternative.