Outlook VBA Contact Phone Number Extraction

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")
        'Return
    '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
          Stop
          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
    Next
   
    If blnFound Then
        objTheContact.BusinessTelephoneNumber = "222-222-2222"
        objTheContact.Save
        work = CStr(objTheContact.BusinessTelephoneNumber)
        cell = CStr(objTheContact.MobileTelephoneNumber)
        email = CStr(objTheContact.Email1Address)
        Stop
    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
        .Save
    End With
    Set olTsk = Nothing
    Set olApp = Nothing
    Set objItem = Nothing
End Sub