Solved: How do I activate an Outlook dialog box, make selection, then return to Excel?

[xjetjockey]

I have a program below that opens the Outlook Address Book. The user selects an address, and the Contact info is put on the sheet. Works great, BUT, I don't know how to programatically select the dialog box, and then programatically go back to Excel. As it now stands I have to manually select Outlook to see the dialog box, and then manually select Excel to get back to my program. Sorry if this is basic stuff, but I'm just a noob.

[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)

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[/vba]

[xjetjockey]

This did the trick.

[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
Dim file As String

file = Application.ActiveWorkbook.Name

Set oContacts = _
Outlook.Application.Session.GetDefaultFolder(olFolderContacts)
On Error Resume Next
Outlook.Application.ActiveWindow.Activate
If Err <> 0 Then
Application.ActivateMicrosoftApp xlMicrosoftMail
End If




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("Main").tbCONTACTEMAIL.Value = c.GetContact.Email1Address
Worksheets("Main").tbFIRSTNAME.Value = c.GetContact.FirstName
Worksheets("Main").tbLASTNAME.Value = c.GetContact.LastName
Worksheets("Main").tbFAX.Value = c.GetContact.BusinessFaxNumber
Worksheets("Main").tbPHONE.Value = c.GetContact.BusinessTelephoneNumber
Worksheets("Main").tbADDRESS.Value = c.GetContact.BusinessAddressStreet
Worksheets("Main").tbCITY.Value = c.GetContact.BusinessAddressCity
Worksheets("Main").tbSTATE.Value = c.GetContact.BusinessAddressState
Worksheets("Main").tbZIP.Value = c.GetContact.BusinessAddressPostalCode
Worksheets("Main").tbCOMPANYNAME.Value = c.GetContact.COMPANYNAME
Next
End If
End With
If Not cEI = "" Then
ActiveWorkbook.Sheets("Main").tbFIRSTNAME.Value = Application.WorksheetFunction.Clean(ActiveWorkbook.Sheets("Main").tbFIRSTNA ME.Value)
ActiveWorkbook.Sheets("Main").tbLASTNAME.Value = Application.WorksheetFunction.Clean(ActiveWorkbook.Sheets("Main").tbLASTNAM E.Value)
ActiveWorkbook.Sheets("Main").tbCOMPANYNAME.Value = Application.WorksheetFunction.Clean(ActiveWorkbook.Sheets("Main").tbCOMPANY NAME.Value)
ActiveWorkbook.Sheets("Main").tbPHONE.Value = Application.WorksheetFunction.Clean(ActiveWorkbook.Sheets("Main").tbPHONE.V alue)
ActiveWorkbook.Sheets("Main").tbCONTACTEMAIL.Value = Application.WorksheetFunction.Clean(ActiveWorkbook.Sheets("Main").tbCONTACT EMAIL.Value)
ActiveWorkbook.Sheets("Main").tbADDRESS.Value = Application.WorksheetFunction.Clean(ActiveWorkbook.Sheets("Main").tbADDRESS .Value)
ActiveWorkbook.Sheets("Main").tbCITY.Value = Application.WorksheetFunction.Clean(ActiveWorkbook.Sheets("Main").tbCITY.Va lue)
ActiveWorkbook.Sheets("Main").tbZIP.Value = Application.WorksheetFunction.Clean(ActiveWorkbook.Sheets("Main").tbZIP.Val ue)
ActiveWorkbook.Sheets("Main").tbFAX.Value = Application.WorksheetFunction.Clean(ActiveWorkbook.Sheets("Main").tbFAX.Val ue)

Call Module1.CheckState
With Worksheets("Main").cboSALUTATION
.Activate
.DropDown
End With
End If

HandleError:
AppActivate "Microsoft Excel"
Exit Sub
Application.Windows(file).Activate
End Sub[/VBA]

[lucas]

Please mark it solved jet.