Solved: Retrieve Outlook Contact Data

I want to be able to click a button which opens an Outlook "Select Names" window (or some other window that allows me to select the contact) , select a contact, then have the following data transferred to my sheet:

Company
First Name
Last Name
Address
City
State
Zip
Work Phone
Work Fax
Email Address

Anybody know how to do this? Thanks.

Maybe this will give you a start. It uses a combobox and the name and email are put in cell A1 but you should be able to work with it from there.

see attached

Thanks. I managed to make it work, but unfortunately it's a tad slow due to the fact that it has to populate the list box. But it works. Takes about 20 seconds to build. Was hoping for a way to utilize the existing Outlook dialog box, but apparently nobody knows how to manage that.

Appreciate your help. Don't suppose you know how to copy a range and paste it into Outlook notes do you? I can xfer data, but the formatting gets trashed.

Thanks again.

The method below will pop up the Outlook Address dialog box, which is what I want. Now, how to take that and extract the data that I want, that's the question. Any ideas?

Sub SetContactsFolderAsInitialAddressList()
Dim oMsg As Outlook.MailItem
Set oMsg = Outlook.Application.CreateItem(olMailItem)
Dim oDialog As Outlook.SelectNamesDialog
Set oDialog = Outlook.Application.Session.GetSelectNamesDialog
Dim oAL As Outlook.AddressList
Dim oContacts As Outlook.Folder

Set oContacts = _
Outlook.Application.Session.GetDefaultFolder(olFolderContacts)

On Error GoTo HandleError
'Look for the AddressList for the default Contacts folder
For Each oAL In Outlook.Application.Session.AddressLists
If oAL.AddressListType = olOutlookAddressList Then
If oAL.GetContactsFolder.EntryID = _
oContacts.EntryID Then
Exit For
End If
End If
Next

With oDialog
.Caption = "Select Customer Contact"
.ToLabel = "Customer C&ontact"
.NumberOfRecipientSelectors = olShowTo
.InitialAddressList = oAL
.AllowMultipleSelection = False
'Let the selected names be the recipients of the new message
.Recipients = oMsg.Recipients

If .Display Then
'Recipients Resolved
End If
End With

HandleError:
Exit Sub
End Sub

Thanks Lucas. I figured out another way to do it. Code still has a problem however. If the user selects cancel when the dialog box opens it won't return him back to Excel. I don't think I have quite figured out how to programatically switch back and forth. If you happen to know I would appreciate it.

[VBA]Sub SetContactsFolderAsInitialAddressList()
Dim oMsg As Outlook.MailItem
Set oMsg = Outlook.Application.CreateItem(olMailItem)
Dim oDialog As Outlook.SelectNamesDialog
Set oDialog = Outlook.Application.Session.GetSelectNamesDialog
Dim oAL As Outlook.AddressList
Dim oContacts As Outlook.Folder
Dim cEI As String
Dim c As Outlook.AddressEntry
Dim olRecipient As Outlook.Recipient


Set oContacts = _
Outlook.Application.Session.GetDefaultFolder(olFolderContacts)

Outlook.Application.ActiveWindow.Activate


On Error GoTo HandleError
'Look for the AddressList for the default Contacts folder
For Each oAL In Outlook.Application.Session.AddressLists
If oAL.AddressListType = olOutlookAddressList Then
If oAL.GetContactsFolder.EntryID = _
oContacts.EntryID Then
Exit For
End If
End If
Next

With oDialog

.Caption = "Select Customer Contact"
.ToLabel = "Customer C&ontact"
.NumberOfRecipientSelectors = olShowTo
.InitialAddressList = oAL
.AllowMultipleSelection = False
.Recipients = oMsg.Recipients
If .Display Then

'Recipients Resolved
For Each olRecipient In .Recipients
cEI = olRecipient.EntryID 'entry id of selected contact
Set c = Outlook.Application.Session.GetAddressEntryFromID(cEI)
Worksheets("Sheet1").Range("A1") = c.GetContact.Email1Address
Worksheets("Sheet1").Range("A2") = c.GetContact.FirstName
Worksheets("Sheet1").Range("A3") = c.GetContact.LastName
Worksheets("Sheet1").Range("A4") = c.GetContact.BusinessFaxNumber
Worksheets("Sheet1").Range("A5") = c.GetContact.BusinessTelephoneNumber
Worksheets("Sheet1").Range("A6") = c.GetContact.BusinessAddressStreet
Worksheets("Sheet1").Range("A7") = c.GetContact.BusinessAddressCity
Worksheets("Sheet1").Range("A8") = c.GetContact.BusinessAddressState
Worksheets("Sheet1").Range("A9") = c.GetContact.BusinessAddressPostalCode
Worksheets("Sheet1").Range("A10") = c.GetContact.CompanyName
Next
End If
End With

HandleError:
AppActivate "Microsoft Excel"
Exit Sub

AppActivate "Microsoft Excel"
End Sub[/VBA]

Try:
[VBA]Application.Windows("book1.xls").Activate[/VBA]

Worked. Muchas Gracias.