Hi,
I have a list of names in a column in an Excel spreadsheet and I would like to get the person's phone number and email address from the global address list in Outlook. I have found a code online but I can't make it work. So far, I am testing this with only one cell (B9). I get a VBA error (objet variable not set) at line:
phoneNumber = contact.BusinessTelephoneNumber
I think that the problem is that contact = nothing, and I don't know what I did wrong.
The code is located in the code space of the worksheet where the list of names is.
Thanks in advance,
NewB47
Windows 7, Excel/Outlook 2010
Code:
<tbody>
</tbody>
I have a list of names in a column in an Excel spreadsheet and I would like to get the person's phone number and email address from the global address list in Outlook. I have found a code online but I can't make it work. So far, I am testing this with only one cell (B9). I get a VBA error (objet variable not set) at line:
phoneNumber = contact.BusinessTelephoneNumber
I think that the problem is that contact = nothing, and I don't know what I did wrong.
The code is located in the code space of the worksheet where the list of names is.
Thanks in advance,
NewB47
Windows 7, Excel/Outlook 2010
Code:
Function GetNS(ByRef app As Outlook.Application) As Outlook.Namespace Set GetNS = app.GetNamespace("MAPI") End Function Function GetItems(olNS As Outlook.Namespace, folder As OlDefaultFolders) As Outlook.Items Set GetItems = olNS.GetDefaultFolder(folder).Items End Function Function GetOutlookApp() As Outlook.Application ' returns reference to native Application object Set GetOutlookApp = Outlook.Application End Function Sub Import_outlook_contact() Dim Outlook As Object Const olFolderContacts As Long = 10 Dim contactName As String Dim contacts As Object Dim contact As Object Dim addressLists As Object ' Outlook.AddressLists Dim GAL As Object ' Outlook.AddressList Dim addressEntries As Object ' Outlook.AddressEntries Dim addressEntry As Object ' Outlook.AddressEntry Dim phoneNumber As String Dim emailAddress As String contactName = Range("B9").Value ' ignore blanks If Len(contactName) = 0 Then Exit Sub End If ' grab Outlook If Outlook Is Nothing Then Set Outlook = GetOutlookApp End If ' get contacts Set contacts = GetItems(GetNS(Outlook), olFolderContacts) ' grab target contact On Error Resume Next Set contact = contacts.Item(contactName) On Error GoTo 0 ' try to find in GAL Set addressLists = GetNS(Outlook).addressLists Set GAL = addressLists.Item("Global Address List") Set addressEntries = GAL.addressEntries On Error Resume Next Set addressEntry = addressEntries.Item(contactName) On Error GoTo 0 If addressEntry Is Nothing Then ' nothing in Contacts Folder or GAL MsgBox "No contact found with this name." Else ' in GAL but not Contacts Folder phoneNumber = contact.BusinessTelephoneNumber 'where I get problems: object variable not set emailAddress = contact.Email1Address End If ' put contact info into adjacent cell Application.EnableEvents = False Range("B9").Offset(0, 2).Value = phoneNumber Range("B9").Offset(0, 3).Value = emailAddress Application.EnableEvents = True End Sub |
<tbody>
</tbody>