# Retrieving outlook contact details using VBA



## NewB47 (Aug 28, 2014)

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 (Aug 30, 2014)

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 (Sep 1, 2014)

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 (Sep 15, 2014)

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 (Sep 18, 2014)

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 (Sep 18, 2014)

NewB47 said:


> 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.
> 
> ...



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 (Sep 19, 2014)

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 (Sep 19, 2014)

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 (Sep 19, 2014)

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 (Sep 19, 2014)

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
```


----------



## NewB47 (Aug 28, 2014)

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>


----------



## NewB47 (Sep 19, 2014)

Where does the error occur (which line is highlighted yellow)?


----------



## REUBEN (Sep 19, 2014)

Right in the first one "Function GetNS(ByRef app As Outlook.Application) As Outlook.Namespace"


----------



## NewB47 (Sep 25, 2014)

Hi Reuben,

I really don't know. I'm not a VBA expert. Maybe someone else can help you?


----------



## REUBEN (Sep 25, 2014)

Thank you for your help. 

Hi All, would anyone else be able to help me?


----------



## MROBER123 (Apr 1, 2019)

REUBEN said:


> Thank you for your help.
> 
> Hi All, would anyone else be able to help me?



Hi there, 

Ha you tried checking the references? if there is any early binding it may be you are using a different version of excel and have missing libraries.


----------



## phillfri (Aug 17, 2019)

Try this. Lets OL find the name object. (I use numbering for error tracking)

Function Get_mail_info(FullName As Variant)
      Dim objOL As Object
      Dim objTI As Object
      Dim OutRec As Object
      Const olTaskItem As Long = 3
40    Set objOL = CreateObject("Outlook.Application")
50    Set objTI = objOL.CreateItem(olTaskItem)
60    objTI.Assign
70    Set OutRec = objTI.Recipients.Add(FullName)
80    OutRec.Resolve
90    If OutRec.Resolved Then
100       On Error GoTo ExitCode
110       Get_mail_info = OutRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
120   End If
ExitCode:
130   Set objOL = Nothing
140   Set objTI = Nothing
160   On Error GoTo 0
End Function


----------

