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

Outlook default reminder for sent mails

Since most of the time, I need to follow up my mails send out to make sure the expected actions are taken, I do add a reminder on my send email. So I can verify in a couple of days if I did get a reaction or the expected action has been taken in the meantime.

In order to automate this, I added the outlook macro shown below. It’s based on the nice example provided by Diane Poremsky. I just improved it a bit to set the default reminder at 10am in 5 days (moving some days forward whenever the 5 days would end in the weekend). After sending an email, a little popup will show up indicating the reminder would be created for within 5 business days. The number of days can quickly be changed or the reminder can fully be discared using the ‘Cancel’ on the pop-up. After some days of usage, I’m very satisfied with the result. The popup will appear after sending the message, so the email will always be sent and won’t be blocked if the pop-up wouldn’t be noticed.

Of course this is only useful when you often need a follow-up on your sent mails…

'Instructions:    
'myT 04/2016, http://myTselection.blogspot.com
  'Default reminder for sent mails: add a default reminder for every sent mail, default 5 working days with popup to cancel or confirm (and set number of days)
  'Instructions:
  'Open Outlook and press [ALT+F11] to open the VBS developer editor
  'Navigate to 'Project 1 VbaProject.OTM' > Microsoft Outlook Objects > ThisOutlookSession
  'Copy and Paste the macro below and close the VBS editor
  'Make sure the line 'Private WithEvents olSentItems as Items' is saved at the top of the file
  Private WithEvents olSentItems As Items
  Attribute olSentItems.VB_VarHelpID = -1
  Private Declare PtrSafe Function ShellExecute _
  Lib "shell32.dll" Alias "ShellExecuteA" ( _
  ByVal hWnd As Long, _
  ByVal Operation As String, _
  ByVal Filename As String, _
  Optional ByVal Parameters As String, _
  Optional ByVal Directory As String, _
  Optional ByVal WindowStyle As Long = vbMinimizedFocus _
  ) As Long
  'Original source: http://www.slipstick.com/developer/code-samples/set-flag-follow-up-using-vba/
  Private Sub Application_Startup()
  'MsgBox ("test startup")
  Dim objNS As NameSpace
  Set objNS = Application.Session
  ' instantiate objects declared WithEvents
  Set olSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items
  Set objNS = Nothing
  End Sub
  Private Sub olSentItems_ItemAdd(ByVal Item As Object)
  'On Error Resume Next
  Dim prompt As String
  Dim dtmTemp As Date
  Dim businessDays As String
  Dim reminderTime As String
  Dim dueDateDays As Integer
  'MsgBox ("test item sent")
  If TypeName(Item) = "MailItem" Then
          businessDays = 5
      dueDateDays = 14
      reminderTime = "10:00:00 AM"
            'Reminder in 5 days, 10 AM
        dtmTemp = DateValue(Now + businessDays) & " " & TimeValue(reminderTime)
        'skip days if reminder would result in weekend
        Do While IsWeekend(dtmTemp)
            dtmTemp = dtmTemp + 1
        Loop
                    'InputBox(prompt[, title] [, default] )
        businessDays = InputBox("Do you want to add a reminder for the email sent? " & vbCrLf & vbCrLf _
        & " Subject: " & Item.Subject & vbCrLf _
        & " To: " & Item.To & vbCrLf & vbCrLf & vbCrLf _
        & "Set # business days for the reminder" & vbCrLf _
        & " Default " & businessDays & " business days: " & WeekdayName(Weekday(dtmTemp), True, vbSunday) & " " & dtmTemp, _
        "Add a reminder for the email sent?", businessDays)
              'Exit sub if user press Cancel button or does not enter any text in the Input field.
        If businessDays = vbNullString Then Exit Sub
              dtmTemp = DateValue(Now + CInt(businessDays)) & " " & TimeValue(reminderTime)
        'skip days if reminder would result in weekend
        Do While IsWeekend(dtmTemp)
            dtmTemp = dtmTemp + 1
        Loop
                           With Item
            .MarkAsTask olMarkThisWeek
              ' sets a due date in 14 days
            .TaskDueDate = Now + dueDateDays
            .ReminderSet = True
            .reminderTime = dtmTemp
            .Save
        End With
    End If
  End Sub

Update 27/06/2016: added check on item type to make sure no error occur when responding to an meeting request.

Babylon - Contacts

I'm a big fan of Babylon to easily translate or explain something. I also use it a lot with my own created "dictionaries". For example: I made some script to easily export all my Microsoft Outlook contacts and create a Babylon dictionary out of it. Whenever I need a name, email, phone number, ... of some contact, I just have to provide a name, company, phone number,... to immediately popup my contacts details with just a click.

Follow these steps if you want to be able to export your own Outlook contacts to Babylon.

1. Export MS Outlook contacts to Excel file: Menu 'File' -> 'Import and export' -> 'Export to file' -> 'Microsoft Excel 97-2003' -> 'Contacts' -> chose some location to save the file
2. Open the generated Excel file
3. Add a new macro in the Excel file: Menu 'Developer' -> 'Visual Basic' -> Sheet1 -> Copy-paste my macro from here :

Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
  "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
  lStructSize As Long
  hwndOwner As Long
  hInstance As Long
  lpstrFilter As String
  lpstrCustomFilter As String
  nMaxCustFilter As Long
  nFilterIndex As Long
  lpstrFile As String
  nMaxFile As Long
  lpstrFileTitle As String
  nMaxFileTitle As Long
  lpstrInitialDir As String
  lpstrTitle As String
  flags As Long
  nFileOffset As Integer
  nFileExtension As Integer
  lpstrDefExt As String
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type
Sub ConvertOutlookContactsToBabylon()
    sFile = "C:\Contacts.gls"
    
    Application.ScreenUpdating = False
    ' turns off screen updating
    Application.DisplayStatusBar = True
    ' makes sure that the statusbar is visible
    Application.StatusBar = "Preparing babylon file in " + sFile
    
    '--------------------------------------------------------------------------
    'Create export file
    '--------------------------------------------------------------------------
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.CreateTextFile(sFile, True)
    f.writeline ("### Glossary title:Contacts")
    f.writeline ("### Author:")
    f.writeline ("### Description:Contacts")
    f.writeline ("### Source language:Dutch")
    f.writeline ("### Source alphabet:Latin")
    f.writeline ("### Target language:Dutch")
    f.writeline ("### Target alphabet:Latin")
    f.writeline ("### Icon:")
    f.writeline ("### Icon2:")
    f.writeline ("### Browsing enabled?Yes")
    
    f.writeline ("### Type of glossary:00000000")
    f.writeline ("### Case sensitive words?0")
    f.writeline ("; DO NOT EDIT THE NEXT **SIX** LINES  - Babylon-Builder generated text !!!!!!")
    f.writeline ("### Glossary id:029f645f6877899f836e9c869d8a89447c6e8e9e8271769a9d659559957889978372869c8477772a9693897f5d89526e7c458944648127444854575a428a9244977c946e5b524147584c559fcc23264eac62515a414f4b8b279a224f5a42474f5f555638993bd86e5b524147584c559f908e2d60475e5a4b597e66833a32294d48429a4d5955")
    f.writeline ("### Confirmation string:7C221QRF")
    f.writeline ("### File build number:01292D7C")
    f.writeline ("### Build:")
    f.writeline ("### Glossary settings:00000000")
    f.writeline ("### Gls type:00000001")
    f.writeline ("; DO NOT EDIT THE PREVIOUS **SIX** LINES  - Babylon-Builder generated text !!!!!!")
    f.writeline ("### Part of speech table:")
    f.writeline ("### Private label id:")
    f.writeline ("### Min version:0")
    f.writeline ("### Regular expression:")
    f.writeline ("### Glossary section:")
    'Find a free column to fill with copy
    ' and find the column to copy from
    For iColumn = 1 To 65000
        'Empty column, stop loop
        colName = CStr(Worksheets(1).Cells(1, iColumn).Value)
        If colName = Empty Then
          lastColumn = iColumn
            Exit For
        End If
        
        'Columns to remove
        If colName = "E-mail Type" Or colName = "E-mail Display Name" Or colName = "E-mail 2 Type" Or colName = "E-mail 2 Type" Or colName = "E-mail 2 Display Name" Or colName = "E-mail 3 Type" Or colName = "E-mail 3 Display Name" Or colName = "Gender" Or colName = "Priority" Or colName = "Private" Or colName = "Sensitivity" Then
          Worksheets(1).Columns(iColumn).Delete (xlShiftToLeft)
          iColumn = iColumn - 1
        End If
        
    Next iColumn
    
    
    'go thru all rows
    For iRow = 2 To 65000
    
        'check if last row to do
        If Worksheets(1).Cells(iRow, 2).Value = Empty And Worksheets(1).Cells(iRow, 4).Value = Empty And Worksheets(1).Cells(iRow + 1, 2).Value = Empty And Worksheets(1).Cells(iRow + 1, 4).Value = Empty Then
            Exit For
        End If
        
        'start new line for babylon display data
        Worksheets(1).Rows(iRow + 1).Insert (xlShiftDown)
        'insert empty row between each contact
        Worksheets(1).Rows(iRow + 2).Insert (xlShiftDown)
        
        'output line, will be written to file
        sLine = ""
        
        'babylon subject
        sSubject = ""
        FullName = CStr(Worksheets(1).Cells(iRow, 2).Value) + " " + CStr(Worksheets(1).Cells(iRow, 4).Value) + "|" + CStr(Worksheets(1).Cells(iRow, 4).Value) + " " + CStr(Worksheets(1).Cells(iRow, 2).Value) + "|"
        
        'keep track of column working in, since cells will be deleted but not in header row
        iColumn = 1
        For headerColumn = 1 To (lastColumn - 1)
            If Worksheets(1).Cells(iRow, iColumn).Value <> Empty Then
                
                'convert value to string
                elementValue = CStr(Worksheets(1).Cells(iRow, iColumn).Value)
                
                
                'eleminiate empty birthday dates
                If elementValue = "0/0/00" Then
                    Worksheets(1).Cells(iRow, iColumn).Value = ""
                Else
                    'insert babylon display data
                    displayData = elementValue
                    
                    'convert email addresses to links
                    If InStr(displayData, "@") And (Not InStr(displayData, " ")) Then
                        displayData = "<a href='mailto:" + elementValue + "'>" + elementValue + "</a>"
                    End If
                    
                    'convert web links
                    If Worksheets(1).Cells(1, headerColumn).Value = "WebPage" Then
                        If Not InStr(elementValue, "http://") Then
                            displayData = "<a href='http://" + elementValue + "'>" + elementValue + "</a>"
                        Else
                            displayData = "<a href='" + elementValue + "'>" + elementValue + "</a>"
                        End If
                    End If
                    
                    'convert phone numbers
                    If InStr(Worksheets(1).Cells(1, headerColumn).Value, "Phone") Or InStr(Worksheets(1).Cells(1, headerColumn).Value, "Fax") Then
                        displayData = Replace(Replace(Replace(elementValue, "+31", "+31."), "+33", "+33."), "+32", "+32.")
                    End If
                    
                    
                    'convert categories
                    If Worksheets(1).Cells(1, headerColumn).Value = "Categories" Then
                        displayArray = Split(displayData, ";")
                        displayData = ""
                        For Each sArrayElement In displayArray
                            displayData = displayData + "<a href='bword://" + sArrayElement + "'>" + sArrayElement + "</a> "
                        Next
                    End If
                        
                        
                    'Put display data in sheet
                    Worksheets(1).Cells(iRow + 1, 1).Value = Worksheets(1).Cells(iRow + 1, 1).Value + "<b>" + Worksheets(1).Cells(1, headerColumn).Value + "</b>: " + Replace(Replace(Replace(displayData, vbCrLf, "<br>"), vbCr, "<br>"), ";", ",") + "<br>"
                    
                    
                    'replace vbCrLf vbCr ; with |
                    elementValue = Replace(Replace(Replace(Replace(elementValue, vbCrLf, "|"), vbCr, "|"), ";", "|"), "||", "|")
                    'replace all special character for babylon search data
                    replacedChars = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(elementValue, " ", "|"), ".", "|"), "@", "|"), ":", "|"), ";", "|"), "-", "|"), "/", "|"), "||", "|"), "||", "|"), "|&|", "|"), "|-|", "|"), "|.|", "|"), "|~|", "|"), "|=|", "|")
                    replacedChars = Replace(Replace(Replace(replacedChars, "+31", "0"), "+33", "0"), "+32", "0")
                    
                    If replacedChars <> elementValue Then
                        Worksheets(1).Cells(iRow, iColumn).Value = elementValue + "|" + replacedChars + "|"
                    Else
                        Worksheets(1).Cells(iRow, iColumn).Value = elementValue + "|"
                    End If
                    
                    If headerColumn = 1 Or headerColumn = 2 Or headerColumn = 3 Or headerColumn = 4 Then
                        If sSubject = "" Then
                            sSubject = elementValue
                        Else
                            sSubject = sSubject + " " + elementValue
                        End If
                    End If
                    
                End If
                
                If Worksheets(1).Cells(1, headerColumn).Value <> "Notes" Then
                    sLine = sLine + Worksheets(1).Cells(iRow, iColumn).Value
                End If
                'handle next cell in next loop of For
                iColumn = iColumn + 1
            Else
                'empty column: remove cell and shift other cells left
                'keep track of original cell location to get the heading name of the cell
                'deleting cells is very slow!
                'Worksheets(1).Cells(iRow, iColumn).Delete (xlShiftToLeft)
                
                'handle next cell in next loop of For, not needed if cells are deleted
                iColumn = iColumn + 1
            End If
        Next headerColumn
        
        sSubject = Replace(sSubject, "|", " ")
        
        'writing to file
        
        f.writeline (Replace(sSubject + "|" + FullName + sLine, "||", "|"))
        f.writeline (Replace(CStr(Worksheets(1).Cells(iRow + 1, 1).Value), vbTab, " "))
        f.writeline ("")
        iRow = iRow + 2
    Next iRow
    
    'Close export file
    f.Close
    
    Application.ScreenUpdating = True
    ' turns off screen updating
    Application.DisplayStatusBar = True
    ' makes sure that the statusbar is visible
    MsgBox "Babylon file prepared in " + sFile
End Sub




4. Close Visual Basic editor


5. Run the created Macro: Menu 'Developer' -> 'Macro' –> 'ConvertOutlookContactsToBabylon'


6. A file called 'c:\Contacts.gls' will be created on your C: drive


7. Open BabylonBuilder.exe and open the gls file 'c:\Contacts.gls': Menu 'File' -> 'Open' (The new version of BabylonBuilder can also be used to compile .gls to .bgl)


8. Press 'Edit screen'


9. Press 'Build screen'


10. Press 'Build'


11. A file called 'Contacts.bgl' file will be created, this is the compile Babylon dictionary.


12. Double click the 'Contacts.bgl' file to load it into Babylon


13. Use Babylon to search on any contact and immediately see all contact details.