We help IT Professionals succeed at work.

Outlook VBA Contact Phone Number Extraction

Last Modified: 2013-11-07
I am building a small macro in Outlook 2003 VBA.  When called, it should extract the name of the sender of the e-mail I'm currently looking at and a new task to the task list that says "Call (Person's Name)" and then show their business and mobile phone numbers.  The phone numbers should be extracted from my contacts (the record in the contacts is found via the e-mail address of the sender).

The extraction of name and e-mail are working fine, the task addition is working fine, and it appears that the contact identification and extraction is working, but no matter what I do the contactitem.BusinessTelephoneNumber and contactitem.MobileTelephoneNumber properties are simply two zero-length strings.  What's frustrating is that contactitem.Email1Address works properly and the correct string is returned.

I know I'm identifying the correct item from my contacts (and from the right contacts list)  because I've tested extensively by adding dummy entries and having it identify them (it works fine and extracts the e-mail address without issue, but still won't give me the phone numbers).

The complete code for the macro is below.  Any help would be greatly appreciated.

Sub AddTask()
    Dim olApp As Outlook.Application
    Dim olTsk As TaskItem
    Dim work As String
    Dim cell As String
    Dim email As String
    Dim objApp As Application
    Dim objNS As NameSpace
    Dim objContacts As MAPIFolder
    Dim colItems As Items
    Dim objItem As Object
    Dim objMessage As Object
    Dim objTheContact As Object
    Dim strAddress As String
    Dim strWhere As String
    Dim blnFound As Boolean
    Dim defaultfolder As Outlook.MAPIFolder
    Dim CItem As Outlook.ContactItem
    Dim i As Integer
    Dim e1, e2, e3 As String
    'error check
    'If ThisOutlookSession.ActiveExplorer.Selection.Item = Nothing Then
        'MsgBox ("No Message Selected")
    'End If
    'Get selected Message
    Set objMessage = ThisOutlookSession.ActiveExplorer.Selection.Item(1)
    'see if this person is a contact and pull numbers
    'get folder to search
    Set objApp = CreateObject("Outlook.Application")
    Set objNS = objApp.GetNamespace("MAPI")
    Set objContacts = objNS.GetDefaultFolder(olFolderContacts)
    strWhere = "[Email1Address] <> vbNullString " & _
             "Or [Email2Address] <> vbNullString " & _
             "Or [Email3Address] <> vbNullString "
    strAddress = LCase(objMessage.SenderEmailAddress)
    StrName = objMessage.SenderName
    Set colItems = objContacts.Items.Restrict(strWhere)
    colItems.SetColumns ("Email1Address, Email2Address, Email3Address")
    For Each objItem In colItems
      'must test for item type to avoid distribution lists
      If TypeName(objItem) = "ContactItem" Then
        If InStr(LCase(objItem.Email1Address), strAddress) > 0 Then
          Set objTheContact = objItem
          blnFound = True
          Exit For
        ElseIf InStr(LCase(objItem.Email2Address), strAddress) > 0 Then
          Set objTheContact = objItem
          blnFound = True
          Exit For
        ElseIf InStr(LCase(objItem.Email3Address), strAddress) > 0 Then
          Set objTheContact = objItem
          blnFound = True
          Exit For
        End If
      End If
    If blnFound Then
        objTheContact.BusinessTelephoneNumber = "222-222-2222"
        work = CStr(objTheContact.BusinessTelephoneNumber)
        cell = CStr(objTheContact.MobileTelephoneNumber)
        email = CStr(objTheContact.Email1Address)
    End If
    Set olApp = New Outlook.Application
    Set olTsk = olApp.CreateItem(olTaskItem)
    With olTsk
        .Subject = "Call " & StrName & " "
        If Len(work) > 1 Then
            .Subject = .Subject & " work: " & work
        End If
        If Len(cell) > 1 Then
            .Subject = .Subject & " cell: " & cell
        End If
        If Len(email) > 1 Then
            .Subject = .Subject & " e-mail: " & email
        End If
        .Status = olTaskInProgress
        '.Importance = olImportanceHigh
        '.DueDate = DateValue("08/06/07")
        '.TotalWork = 40
        '.ActualWork = 20
    End With
    Set olTsk = Nothing
    Set olApp = Nothing
    Set objItem = Nothing
End Sub

Watch Question

Top Expert 2010
This one is on us!
(Get your first solution completely free - no credit card required)


Awesome!!! Works great, thanks for the effort!
Top Expert 2010

You're welcome.  Glad I could help out.
Unlock the solution to this question.
Join our community and discover your potential

Experts Exchange is the only place where you can interact directly with leading experts in the technology field. Become a member today and access the collective knowledge of thousands of technology experts.

*This site is protected by reCAPTCHA and the Google Privacy Policy and Terms of Service apply.


Please enter a first name

Please enter a last name

8+ characters (letters, numbers, and a symbol)

By clicking, you agree to the Terms of Use and Privacy Policy.