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

About JP

I'm just an average guy who writes VBA code for a living. This is my personal blog. Excel and Outlook are my thing, with a sprinkle of Access and Word here and there. Follow this space to learn more about VBA. Keep Reading »


Related Articles:


Share This Article:

Share and bookmark this articledelicious buttonfacebook buttonlinkedin buttonstumbleupon buttontwitter button

comment bubble 14 Comment(s) on Export Outlook Contacts to Excel:

  1. When I execute the code set above, the loop that starts "For i = 1 to myContactItems.Count" [myContactItems.Count = 169] executes 17 loops successfully, then on the 18th loop I get a "Type mismatch" error when it reads the line "Set ThisContact = myContactItems.item(i)". If I understand this correctly, it's saying that the item it's trying to poll is not a contact item, which doesn't make sense because it's only polling contact items. Has the code found a corrupt contact record? Any help will be very much appreciated.

  2. The specific item it's stopping on, are you sure it's a contact? The only thing I can think of is that the contacts folder is storing something other than a contact.

  3. Ernesto writes:

    Hello JP

    I have a friends that, need to merge several contact folders and then export merged to Excel, could you have some idea?

    Regards

    Ernesto

  4. David Jenkins writes:

    I've been away for so long, I need some help.

    I get a Compile Error: User defined type not defined

    I know its simple but I can't remember.

    Thanks

    • You'll need to set a reference to the Outlook object library in the VBIDE. Go to Tools » References and find "Microsoft Outlook x.0 Object Library" and select the checkbox. Click "OK" and it should work.

  5. Mary Haskell writes:

    JP when I execute this code I recieve a Run-Time'13' error

    When I go to debug it takes me to….
    Set ThisContact = myContactItems.Item(i)

  6. Mary,
    What is the value of i when the code stops? The item it's stopping on may not be a Contact.

  7. Sorry to have spaced on getting back to this post and the many responses — which I am very thankful for. Anyway, I inserted "On Error GoTo Next" code to bypass the chokepoint and it seems to behave wonderfully. I think I may have encountered a distribution list, which is also a Contact item, but not a true contact. I don't know of a way to confirm this, but as I said, the On Error coding bypasses the hangup, so I'm happy with the result. All true contacts make it into the listing.

    Thanks again for everyone's input.

  8. Mary Haskell writes:

    I figured out the error by adding my contacts one by one. It appears that the code doesn't allow for a "distrubution list"

    I put all of my contact back in the default contacts file leaving out all distrubution list and it work like a charm.

    Thanks

  9. Mary Haskell writes:

    Scot can you give me an idea of where to put the “On Error GoTo Next” in the code? Thanks

  10. Mary –

    Update your code like this:

    On Error Resume Next
    Set ThisContact = myContactItems.item(i)
    On Error Goto 0

    Should work, but you might need to adjust the position of the "On Error Goto 0"

  11. Abhijit writes:

    Hello JP

    I want to extract data from the E-mail address field , How could I do that.

    could you have some idea ?

    Regards,

  12. michael writes:

    Hello JP,

    your code is very helpfull.

    is there a way to make the same code work for a java application?

    thank you.

This article is closed to any future comments.
learn excel dashboards