Retrieving outlook contact details using VBA

[NewB47]

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:

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>

 

[Damon Ostrander]

Hi NewB47,

It appears that the contact object variable did not get set because the contact named in cell B9 does not exist--at least not by that exact name. The name in B9 must exactly match the contact name.

Damon

 

[NewB47]

Hi Damon,
Thanks for your comment. I don't think that is problem because the address entry object works. In the end, I've solved this using:

emailAddress = addressEntry.GetExchangeUser.PrimarySmtpAddress
phoneNumber = addressEntry.GetExchangeUser.BusinessTelephoneNumber

 

[REUBEN]

Hi There,

I am trying to do quite the same as you except that I dont need thier phone numbers just the email. But the way the names are expressed in the name column of my worksheet, "SURNAME, Firstname".

As I'm a complete beginner with VBA I do not follow how to tweak the above code. Could you please help me with this?

Here's your code that I tried to fit my requirement.

Remember the names are in column D and begin from the 4th row.

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("D4").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("D4").Offset(0, 2).Value = emailAddress
Application.EnableEvents = True


End Sub

 

[NewB47]

Hi Reuben,

Try this - this is was worked for me (leave the functions at the top). Your contacts should be written exactly the same as in the Outlook database (it's case sensitive) otherwise it will not work.

Sub Import_outlook_contact() '----------------------------------------------- '------- Import outlook contact details ------- '----------------------------------------------- Application.ScreenUpdating = False Dim Outlook As Object Const olFolderContacts As Long = 10 Dim contactName(number of contacts you have) As String 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 emailAddress(number of contacts you have) As String For i = 1 To number of contacts you have contactName(i) = Range("D4").Offset(i - 1, 0).Value Next ' grab Outlook If Outlook Is Nothing Then Set Outlook = GetOutlookApp End If ' Find contacts in Global address list Set addressLists = GetNS(Outlook).addressLists Set GAL = addressLists.Item("Global Address List") Set addressEntries = GAL.addressEntries For i = 1 To number of contacts you have On Error Resume Next Set addressEntry = addressEntries.Item(contactName(i)) On Error GoTo 0 If contactName(i) <> "" Then 'skipping blanks If addressEntry.Name = contactName(i) Then ' contact in Global address list emailAddress(i) = addressEntry.GetExchangeUser.PrimarySmtpAddress Else ' contact not in Global address list MsgBox contactName(i) & " not found in directory. Full name is required." End If End If Next ' put contact info into adjacent cell Application.EnableEvents = False For i = 1 To number of contacts you have Range("D4").Offset(i - 1, 3).Value = emailAddress(i) Next Application.EnableEvents = True End Sub

<tbody>
</tbody>

 

[REUBEN]

Hi Reuben,

Try this - this is was worked for me (leave the functions at the top). Your contacts should be written exactly the same as in the Outlook database (it's case sensitive) otherwise it will not work.

Sub Import_outlook_contact() '----------------------------------------------- '------- Import outlook contact details ------- '----------------------------------------------- Application.ScreenUpdating = False Dim Outlook As Object Const olFolderContacts As Long = 10 Dim contactName(number of contacts you have) As String 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 emailAddress(number of contacts you have) As String For i = 1 To number of contacts you have contactName(i) = Range("D4").Offset(i - 1, 0).Value Next ' grab Outlook If Outlook Is Nothing Then Set Outlook = GetOutlookApp End If ' Find contacts in Global address list Set addressLists = GetNS(Outlook).addressLists Set GAL = addressLists.Item("Global Address List") Set addressEntries = GAL.addressEntries For i = 1 To number of contacts you have On Error Resume Next Set addressEntry = addressEntries.Item(contactName(i)) On Error GoTo 0 If contactName(i) <> "" Then 'skipping blanks If addressEntry.Name = contactName(i) Then ' contact in Global address list emailAddress(i) = addressEntry.GetExchangeUser.PrimarySmtpAddress Else ' contact not in Global address list MsgBox contactName(i) & " not found in directory. Full name is required." End If End If Next ' put contact info into adjacent cell Application.EnableEvents = False For i = 1 To number of contacts you have Range("D4").Offset(i - 1, 3).Value = emailAddress(i) Next Application.EnableEvents = True End Sub

<tbody>
</tbody>

Hi There,

Thank you for your reply.

I'm sorry if this sounds silly, but where do I get the 'number of contacts I have' from?

Also, I would like this code to pull the contacts from two user IDs and mailboxes one is for me only and one is a shared mailbox (and that has a lot of contacts).

Thanks.

 

[NewB47]

The 'number of contacts I have' is the number of contacts/lines you have in column D. If this number is changing, just use something like 500. The loop in the code is looking at one line after the other.

This code pulls data from the global address list in outlook, no matter of who is logged on to outlook. If you work in a firm, all the firm contacts will be in that list. If you want to pull 'private' contacts, there's a way of doing that - pulling contacts from a folder in outlook - but I don't have the code for it. You can find it easily on the internet.

Good luck.

 

[REUBEN]

Hi there,

thanks for your reply.

I tried using the code with 500 as the number of contacts but when I run the module it gives a compile error Sub or Function not defined and has the yellow pointer of the debugger at - Sub Import_outlook_contact()

 

[NewB47]

Have you copied the 3 functions before the sub?
The functions + the sub need to be in the VBA page of where your contacts are (ie: in Microsoft excel object and not in a module).

 

[REUBEN]

Yes, I've added them in now but I still receive this error "User defined type not defined".

Here's my 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()


Application.ScreenUpdating = False
Dim Outlook As Object
Const olFolderContacts As Long = 10


Dim contactName(500) As String
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 emailAddress(500) As String


For i = 1 To 500
contactName(i) = Range("D4").Offset(i - 1, 0).Value
Next


' grab Outlook
If Outlook Is Nothing Then
Set Outlook = GetOutlookApp
End If


' Find contacts in Global address list
Set addressLists = GetNS(Outlook).addressLists
Set GAL = addressLists.Item("Global Address List")
Set addressEntries = GAL.addressEntries


For i = 1 To 500
On Error Resume Next
Set addressEntry = addressEntries.Item(contactName(i))
On Error GoTo 0


If contactName(i) <> "" Then 'skipping blanks
If addressEntry.Name = contactName(i) Then
' contact in Global address list
emailAddress(i) = addressEntry.GetExchangeUser.PrimarySmtpAddress
Else
' contact not in Global address list
MsgBox contactName(i) & " not found in directory. Full name is required."
End If
End If
Next


' put contact info into adjacent cell
Application.EnableEvents = False
For i = 1 To 500
Range("D4").Offset(i - 1, 3).Value = emailAddress(i)
Next


Application.EnableEvents = True


End Sub