Solved: Extracting Contact data from GetSelectNamesDialog - How?

[xjetjockey]

I'm working in Excel and Outlook 2007. The following code runs from Excel. The code opens the Address Dialog. I would like to then select a contact and extract the contact's business name, business street address, business city, business state, business zip, business phone, contact first and last name, contact email address and dump it to some cells on a spreadsheet. Can anyone please help me with this?

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

[xjetjockey]

Figured out the answer to my own question. See below. Another question if anyone knows this I would appreciate it. How do I programatically activate the dialog box, and then switch back to Excel once the selection is made? As it is now I have to manually select Outlook to see the dialog box, and then manually select Excel to return to it. Thanks.

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)

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
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:
Exit Sub
End Sub

[xjetjockey]

I figured it out. Here's the code if anyone is interested:

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