Export Outlook Contacts to Excel
September 6, 2008 – 9:02 pmHere 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).
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 | 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
Seriously, download it before the free version goes pay.
