Outlook GetSelectNamesDialog questions

[bnj1776]

I'm trying to display the SelectNamesDialog with a subset of the Contacts to allow the user to pick one so that later I can pull all of that contacts information into Excel.

First, I'm getting a list of contacts that have been marked as "Customers" via the contact field User1

Then I'm adding each of those contacts to the "InitialAddressList" to the SelectNamesDialog.

But this is only filling in the "To" field with initial values, not limiting the Contact list to only those I'm wanting to show.


Not what I'm needing, so questions:

Is it possible to limit the displayed Contacts list (not the "To" field which will be hidden with NumberOfRecipientSelectors = olShowNone)?

If it is not, would it be possible to create a temporary contacts folder with copies of just the entries I need and then use that folder instead of the default when displaying the Select Names Dialog window?

Or is there a better way I should be looking at???

Thank you,
Brian

Option Explicit

Sub Contact_User1()
    
    Dim objOutlook As Object
    Set objOutlook = CreateObject("Outlook.Application")
    
    Dim objNamespace As Object
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    
[COLOR=#008000]'   Check for the default address list in the Contacts folder[/COLOR]
    On Error GoTo ErrorHandler
    Dim objAddressList As Outlook.AddressList
    For Each objAddressList In Outlook.Application.Session.AddressLists
        If objAddressList.AddressListType = olOutlookAddressList Then
            If objAddressList.GetContactsFolder.EntryID = objNamespace.GetDefaultFolder(olFolderContacts).EntryID Then
                Exit For
            End If
        End If
    Next
    On Error GoTo 0
    
[COLOR=#008000]'   Find the desired Customer group[/COLOR]
    Dim objContacts As Object
    Set objContacts = objNamespace.GetDefaultFolder(olFolderContacts).Items
    Dim objItems As Object
    Set objItems = objContacts.Restrict("[User1] = 'Customer'")
    Dim objItem As Object
    Dim sContacts As String
[COLOR=#008000]'   sContacts = vbNullString
'   For Each objItem In objItems
'       If (objItem.Class = olContact) Then
'           If sContacts <> vbNullString Then
'               sContacts = sContacts & "; "
'           End If
'           sContacts = sContacts & objItem.Email1Address
'       End If
'   Next
'   Debug.Print sContacts 'These are the address to choose from[/COLOR]


    
    Dim objDialog As Object
    Set objDialog = objOutlook.Session.GetSelectNamesDialog


    With objDialog
        .Caption = "Select Customer Contact"
        .ShowOnlyInitialAddressList = True
        .AllowMultipleSelection = False
        .NumberOfRecipientSelectors = olShowTo[COLOR=#008000] 'change to olShowNone[/COLOR]
        For Each objItem In objItems
            If (objItem.Class = olContact) Then
                .recipients.Add (objItem.Email1Address)
                .InitialAddressList.AddressEntries.Add (objItem.Email1Address)
            End If
        Next
        .Display
    End With


    Set objAddressList = Nothing
    Set objContacts = Nothing
    Set objItems = Nothing
    Set objItem = Nothing
    Set objDialog = Nothing
    
ErrorHandler:
    Exit Sub
End Sub