Launching Select Names Dialog from a VBA dialog

Hello Experts.

Please does anyone know how to write a line of VBA code that will launch the select names outlook dialogue box. This is the one that appears when you write a new e-mail and click the "To..." button to choose recipients. Having launched this, I also need to retrieve the list of selected names from the "To ->", "Cc ->" and "Bcc ->" boxes when the dialog is closed.

Any help on this would be greatly appreciated.
Who is Participating?
Jim HornMicrosoft SQL Server Developer, Architect, and AuthorCommented:
First, set a reference (in any code module, Tools Menu:Reference) to Microsoft CDO Object Library and Microsoft Outlook Object Library.
Then, here's the function, you'll have to slice it-dice it to suit your needs.

Hope this helps.

Public Function fn_outlook_select_names(ByRef oMail As MailItem) As Outlook.MailItem
'Display the Microsoft Outlook 'Select Names' dialog to let user pick names

'Not available in Outlook object model, must use CDO, but return an Outlook MailItem.
'(What a pain...)

On Error GoTo error_handler

Dim oOutlook As Outlook.Application
Set oOutlook = CreateObject("Outlook.Application")

Dim oReturnMail As Outlook.MailItem
Set oReturnMail = oOutlook.CreateItem(olMailItem)

Dim x As Long

' start CDO session
Dim oSession As MAPI.Session
Set oSession = CreateObject("MAPI.Session")
oSession.Logon , , False, False

'FIXME: Figure out how to feed current To:Cc:Bcc settings into form

Dim sMessage As String

'Show address book (Cancel button creates an error that needs to be trapped)
On Error Resume Next
Dim cCDORecipients As MAPI.Recipients
Set cCDORecipients = oSession.AddressBook(, "Select Names", , , 3, "To", "Cc", "Bcc")

If Err = 0 Then
    ' put CDO recipients into Outlook message
    Dim cRecipients As Recipients, oRecipient As Recipient
    Dim oCDORecipient As MAPI.Recipient
    For Each oCDORecipient In cCDORecipients
        Set oRecipient = cRecipients.Add(oCDORecipient.AddressEntry.Address)
        If Err = 287 Then
            ' security block triggered
            sMessage = "Outlook cannot add recipients, because you clicked No on the "
            sMessage = sMessage & "e-mail address access dialog. You need to try again and click Yes "
            sMessage = sMessage & "this time."
            MsgBox sMessage, vbOKOnly, "E-mail Address Access"
            Exit For
        End If
ElseIf Err = -2147221229 Then
    'User canceled the address book dialog, do nothing or provide a message to user
End If

Set oMail = Nothing

For x = 1 To cCDORecipients.Count
    Select Case cCDORecipients.Item(x).Type
        Case 1
            If x = 1 Then oReturnMail.To = ""
            oReturnMail.To = oReturnMail.To & "; " & cCDORecipients(x).Name
        Case 2
            If x = 2 Then oReturnMail.CC = ""
            oReturnMail.CC = oReturnMail.CC & "; " & cCDORecipients(x).Name
        Case 3
            If x = 3 Then oReturnMail.BCC = ""
            oReturnMail.BCC = oReturnMail.BCC & "; " & cCDORecipients(x).Name
    End Select

Set fn_outlook_select_names = oReturnMail

    On Error Resume Next
    Set cCDORecipients = Nothing
    Set oRecipient = Nothing
    Set oCDORecipient = Nothing
    Set cRecipients = Nothing
    Set oSession = Nothing
    Exit Function

    'Trap this
    Call sb_error_handler(Err, "sb_outlook_select_names")
    Resume exit_function

End Function
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.