I have cobbled together some code designed to allow the user to choose a specific person from their Outlook contacts and return selected info for that contact in cells for use in the workbook. It always returns a different person's info than the one chosen in the GetSelectNamesDialog box. It is somewhat random but typically a close by contact alphabetically. I had co-workers try it and they get the same results. I have tried anything and everything that I could find without any different result. Running Office 365. Thank you.
VBA Code:
Sub OutlookContactSummary()
Dim outApp As Outlook.Application
Dim outDialog As SelectNamesDialog
Dim myAddrList As AddressList
Dim myAddrEntry As AddressEntry
Dim AliasName As String
Set outApp = GetObject(, "Outlook.Application")
Set outDialog = outApp.Session.GetSelectNamesDialog
Set myAddrList = outApp.GetNamespace("MAPI").AddressLists("Contacts")
With outDialog
.AllowMultipleSelection = False
.InitialAddressList = myAddrList
.ShowOnlyInitialAddressList = True
If .Display Then
AliasName = outDialog.Recipients.Item(1).Name
Set myAddrEntry = myAddrList.AddressEntries(AliasName)
Range("F3").Value = myAddrEntry.GetContact.FirstName
Range("G3").Value = myAddrEntry.GetContact.LastName
Range("M3").Value = myAddrEntry.GetContact.Email1Address
Range("H3").Value = myAddrEntry.GetContact.CompanyName
Range("I3").Value = myAddrEntry.GetContact.BusinessAddressStreet
Range("J3").Value = myAddrEntry.GetContact.BusinessAddressCity
Range("K3").Value = myAddrEntry.GetContact.BusinessAddressState
Range("L3").Value = myAddrEntry.GetContact.BusinessAddressPostalCode
End If
End With
Set outApp = Nothing
Set outDialog = Nothing
Set myAddrList = Nothing
Set myAddrEntry = Nothing
End Sub