Problem Accessing Exchange Contact Items

[ImagineTNT]

I am having a problem accessing Exchange Contact Items:

I have a function to open a contact select so the user can select which contact to use. If I select from my own machine's contact user list it works great. But if I try to select a contact from the Exchange list it says that it can't find the object.


Function selectContact() As outlook.ContactItem
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 contact As outlook.AddressEntry

Dim test As outlook.ContactItem

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

On Error GoTo HandleError

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

If oDialog.Display Then
'Recipients Resolved
If oDialog.Recipients.Count = 1 Then
cEI = oDialog.Recipients(1).EntryID 'entry id of selected contact
Set contact = outlook.Application.Session.GetAddressEntryFromID(cEI)
Set selectContact = contact.GetContact
End If
End If

HandleError:
If Err <> 0 Then
MsgBox "Error: " & Err.Number & " " & Err.Description
End If

Exit Function

End Function