Export Outlook Contacts to Excel

Here is the last of the add-in code I was working on. This piece extracts the properties from Contact Items into Excel, using early binding to speed up the code, but with GetObject/CreateObject calls to attempt to hook into an existing instance of Outlook. What, do you mean you don't leave Outlook running all day while you're in the office?

This code uses the same technique from the Tasks extracting code I posted earlier, so this code below should look pretty familiar to you if you check out that post. An array is populated with the contact information, which is then dumped in one shot to the worksheet.

Something seems to be wrong with my code syntax highlighter, you'll need to cut and paste the code in order to view it proper. It does cut and paste properly, even though you can't view it all.

I haven't tested this but it should work as written. This code is just a demonstration with three fields (Company name, Country and Phone Number). If you want to export more fields, look up the properties of the ContactItem here.

I also included some additional code at the bottom which can be used in other routines to prompt the user to save the file, with a sample filename, filter and title so you can see how code like that would work. It also handles the possibility that the user clicks "Yes" to save the file, but then presses Cancel in the file save dialog box (or doesn't type anything and presses OK).

Sub ExtractContacts()
'
' If Outlook is not open, it still works, but much slower (~8 secs vs. 2 secs w/ Outlook open).
'
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim myContactItems As Outlook.Items
Dim ThisContact As Outlook.ContactItem
Dim MyBook As Excel.Workbook
Dim rngStart As Excel.Range
Dim rngHeader As Excel.Range
Dim FileToSave As String
Dim NextRow As Long
Dim ColCount As Long
Dim i As Long
Dim arrData() As Variant

Application.ScreenUpdating = False

' get or create Outlook object and make sure it exists before continuing
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
  Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
If olApp Is Nothing Then
  MsgBox "Cannot start Outlook.", vbExclamation, APPNAME
  GoTo ExitProc
End If

Set olNS = olApp.GetNamespace("MAPI")
Set myContactItems = olNS.GetDefaultFolder(olFolderContacts).Items

If myContactItems.Count > 0 Then

  Set MyBook = Excel.Workbooks.Add
  MyBook.Sheets(1).Name = "Contacts"
  Set rngStart = MyBook.Sheets(1).Range("A1")
  Set rngHeader = Range(rngstart, rngstart.Offset(0,3))

  ' with assistance from Jon Peltier http://peltiertech.com/WordPress and
  ' http://support.microsoft.com/kb/306022

  rngHeader.Value = Array("Company Name", "Country", "Telephone Number")

  ColCount = rngHeader.Columns.Count

  ' now that we know how many rows and columns we need,
  ' resize the array accordingly
  ReDim arrData(1 To myContactItems.Count, 1 To ColCount)

'
' to make it more obvious:
' Dim LastRow As Long
' Dim LastColumn As Long
' LastRow = myContactItems.Count
' LastColumn = rngHeader.Columns.Count
' ReDim arrData( 1 to LastRow, 1 to LastColumn)
'
'
  For i = 1 to myContactItems.Count
    Set ThisContact = myContactItems.item(i)

    arrData(i, 1) = ThisContact.CompanyName
    arrData(i, 2) = ThisContact.HomeAddressCountry
    arrData(i, 3) = ThisContact.BusinessTelephoneNumber

  Next i

  rngStart.Offset(1, 0).Resize(myContactItems.Count, ColCount).Value = arrData

Else
  MsgBox "I don't see any contacts in your default Contacts folder. Exiting now...", vbOKOnly, APPNAME
End If

If MsgBox("Would you like to save the exported contacts list now?", vbInformation + vbYesNo) = vbYes Then
  FileToSave = Application.GetSaveAsFilename("Outlook Contacts", FileFilter:="Microsoft Office Excel Workbook (*.xls), *.xls", Title:="Save File")
      If FileToSave <> False Then
        ActiveWorkbook.SaveAs FileToSave, FileFormat:=xlNormal
      End If
End If

ExitProc:
Application.ScreenUpdating = True
Set ThisContact = Nothing
Set rngStart = Nothing
Set MyBook = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set myContactItems = Nothing
Erase arrData
End Sub

Enjoy,
JP

Related Articles:

• December 24, 2009 -- Save money, use VBA
• March 31, 2009 -- Extract Calendar data from Outlook, Redux
• August 29, 2008 -- Export Outlook Tasks to Excel