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>

 

[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