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:

[TABLE="width: 500"]
<tbody>[TR]
[TD]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[/TD]
[/TR]
</tbody>[/TABLE]

 

[NewB47]

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

 

[REUBEN]

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

 

[NewB47]

Hi Reuben,

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

 

[REUBEN]

Thank you for your help.

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

 

[MROBER123]

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]

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