Jim try this
Option Explicit
' Purpose:
' Search Outlook Contacts by Telephone Number
' Return Contact Phone Numbers with Type Label
'
' Add New Class Module
' Name: AddInPbkOlk
'
DefBool B: DefLng L: DefStr S: DefVar V: DefObj O
'
Const m_strCLSID = "Outlook.Application"
Private m_strNumberType As String
'
'
'
Public Function FindNumber(sTele, _
Optional bAllItems = True, _
Optional bDisplayErr = True) As Object
' Comments : Find Contact with matching Telephone Number
' Parameters: Telephone Number
' Returns : Contact object or Nothing
' Modified : 12:18 PM 08/08/2002
'-------------------------------
Const olContact = 2
Const olFolderContacts = 10
Dim oOl, oNsp, oItms, oC
'
On Error Resume Next
' Get Outlook Application Object
Set oOl = OlkApp()
' If Not Object Then Exit procedure
If (oOl Is Nothing) Then GoTo FindNumberExit
On Error GoTo FindNumberEH
' Let Outlook properly format number
Set oC = oOl.CreateItem(olContact)
oC.OtherTelephoneNumber = sTele
sTele = oC.OtherTelephoneNumber
Set oC = Nothing
' Set NameSpace Object
Set oNsp = oOl.Getnamespace("MAPI")
' Select All Contacts Items or Default
If bAllItems = True Then
For Each oItms In GetAllContactItems(oNsp)
Set oC = GetNumberFromItems(oItms, sTele)
If (Not oC Is Nothing) Then Exit For
Next
Else
With oNsp.Getdefaultfolder(olFolderContacts)
Set oC = GetNumberFromItems(.Items, sTele)
End With
End If
' Verify Contact was found
If (Not oC Is Nothing) Then
Set FindNumber = oC
Set oC = Nothing
End If
' Release Objects
Set oItms = Nothing
Set oNsp = Nothing
Set oOl = Nothing
FindNumberExit:
Exit Function
FindNumberEH:
If bDisplayErr = True Then
MsgBox Err.Description, , "FindNumberEH"
End If
Err.Clear
Resume FindNumberExit
End Function
'
Public Function GetNumbers(objContact) As Collection
' Comments : Get phone numbers with Label
' Example : (xxx) xxx-xxxx [Home Phone]
' Parameters: Contact Object
' Returns : Collection
' Modified : 04/27/2002
'-----------------------------------------
Dim oC, cNbrs As New Collection
On Error Resume Next
Set oC = objContact
With oC
If Len(.HomeTelephoneNumber) <> 0 Then _
cNbrs.Add AddLabel("HomeTelephoneNumber", .HomeTelephoneNumber)
'
If Len(.Home2TelephoneNumber) <> 0 Then _
cNbrs.Add AddLabel("Home2TelephoneNumber", .Home2TelephoneNumber)
'
If Len(.HomeFaxNumber) <> 0 Then _
cNbrs.Add AddLabel("HomeFaxNumber", .HomeFaxNumber)
'
If Len(.BusinessTelephoneNumber) <> 0 Then _
cNbrs.Add AddLabel("BusinessTelephoneNumber",
..BusinessTelephoneNumber)
'
If Len(.Business2TelephoneNumber) <> 0 Then _
cNbrs.Add AddLabel("Business2TelephoneNumber",
..Business2TelephoneNumber)
'
If Len(.BusinessFaxNumber) <> 0 Then _
cNbrs.Add AddLabel("BusinessFaxNumber", .BusinessFaxNumber)
'
If Len(.AssistantTelephoneNumber) <> 0 Then _
cNbrs.Add AddLabel("AssistantTelephoneNumber",
..AssistantTelephoneNumber)
'
If Len(.CallbackTelephoneNumber) <> 0 Then _
cNbrs.Add AddLabel("CallbackTelephoneNumber",
..CallbackTelephoneNumber)
'
If Len(.CompanyMainTelephoneNumber) <> 0 Then _
cNbrs.Add AddLabel("CompanyMainTelephoneNumber",
..CompanyMainTelephoneNumber)
'
If Len(.CarTelephoneNumber) <> 0 Then _
cNbrs.Add AddLabel("CarTelephoneNumber", .CarTelephoneNumber)
'
If Len(.PrimaryTelephonenumber) <> 0 Then _
cNbrs.Add AddLabel("PrimaryTelephonenumber",
..PrimaryTelephonenumber)
'
If Len(.ISDNNumber) <> 0 Then _
cNbrs.Add AddLabel("ISDNNumber", .ISDNNumber)
'
If Len(.MobileTelephoneNumber) <> 0 Then _
cNbrs.Add AddLabel("MobileTelephoneNumber", .MobileTelephoneNumber)
'
If Len(.OtherFaxNumber) <> 0 Then _
cNbrs.Add AddLabel("OtherFaxNumber", .OtherFaxNumber)
'
If Len(.OtherTelephoneNumber) <> 0 Then _
cNbrs.Add AddLabel("OtherTelephoneNumber", .OtherTelephoneNumber)
'
If Len(.PagerNumber) <> 0 Then _
cNbrs.Add AddLabel("PagerNumber", .PagerNumber)
'
If Len(.RadioTelephoneNumber) <> 0 Then _
cNbrs.Add AddLabel("RadioTelephoneNumber", .RadioTelephoneNumber)
'
If Len(.TelexNumber) <> 0 Then _
cNbrs.Add AddLabel("TelexNumber", .TelexNumber)
'
If Len(.TTYTDDTelephoneNumber) <> 0 Then _
cNbrs.Add AddLabel("TTYTDDTelephoneNumber", .TTYTDDTelephoneNumber)
'
End With
Set GetNumbers = cNbrs
Set oC = Nothing
End Function
'
Public Function GetAllContactItems(oNs) As Collection
' Comments : Locate and load all Items,
' Parameters: None
' Returns : Collection of Items objects
' Modified : 12:18 PM 07/29/2001
'-------------------------------
Const sDefMsgCls = "IPM.Contact"
Dim cCol As New Collection
'
AddItems oNs.Folders, cCol, sDefMsgCls
Set GetAllContactItems = cCol
Set cCol = Nothing
End Function
'
Private Sub AddItems(parent, cCol, strDefMsgCls)
' Comments : Add Items to Collection
' Parameters: Folder, Collection, Class
' Returns :
' Modified : 12:18 PM 07/29/2001
'-------------------------------
Dim vFld
'
On Error Resume Next
For Each vFld In parent
If InStr(vFld.DefaultMessageClass, strDefMsgCls) <> 0 Then
cCol.Add vFld.Items
End If
AddItems vFld.Folders, cCol, strDefMsgCls
DoEvents
Next
End Sub
'
Private Function GetNumberFromItems(oItems, sTel) As Object
' Comments : Search Items for matching Number
' Parameters: Items, Telephone Number
' Returns : Contact object
' Modified : 12:18 PM 07/29/2001
'-------------------------------
Dim aNbrFields, vField, sFilter, oContact
'
aNbrFields = NumberFieldsAndLabels().keys
For Each vField In aNbrFields
sFilter = "[" & vField & "]=" & AddQuote(sTel)
Set oContact = oItems.Find(sFilter)
If (Not oContact Is Nothing) Then
NumberType = NumberFieldsAndLabels(vField)
Set GetNumberFromItems = oContact
Set oContact = Nothing
Exit For
End If
Next
'
End Function
'
Public Function GetNumberFieldsAndLabels() As Object
Set GetNumberFieldsAndLabels = NumberFieldsAndLabels
End Function
'
Private Function NumberFieldsAndLabels() As Object
' Comments : Add Number Fields and
' : Label Captions to Dictionary Object
' Parameters: None
' Returns : Dictionary object
' Modified : 12:18 PM 07/29/2001
'-------------------------------
Dim oDic
'
On Error Resume Next
Set oDic = CreateObject("Scripting.Dictionary")
With oDic
.Add "HomeTelephoneNumber", "Home Phone"
.Add "Home2TelephoneNumber", "Home Phone 2"
.Add "HomeFaxNumber", "Home Fax"
.Add "BusinessTelephoneNumber", "Business Phone"
.Add "Business2TelephoneNumber", "Business Phone 2"
.Add "BusinessFaxNumber", "Business Fax"
.Add "AssistantTelephoneNumber", "Assistant Phone"
.Add "CallbackTelephoneNumber", "Callback Phone"
.Add "CompanyMainTelephoneNumber", "Company Main Phone"
.Add "CarTelephoneNumber", "Car Phone"
.Add "Primary Phone", "Primary Phone"
.Add "ISDNNumber", "ISDN"
.Add "MobileTelephoneNumber", "Mobile Phone"
.Add "OtherFaxNumber", "Other Fax"
.Add "OtherTelephoneNumber", "Other Phone"
.Add "PagerNumber", "Pager"
.Add "RadioTelephoneNumber", "Radio"
.Add "TelexNumber", "Telex"
.Add "TTYTDDTelephoneNumber", "TTYTDD Phone"
End With
Set NumberFieldsAndLabels = oDic
Set oDic = Nothing
End Function
'
Private Function AddLabel(strField, strValue) As String
' Comments : Add Tab and Brackets to string
'-------------------------------------------
AddLabel = strValue & vbTab & "[" & NumberFieldsAndLabels(strField) &
"]"
End Function
'
Private Function AddQuote(strText) As String
' Comments : Add quotes to string
'---------------------------------
AddQuote = Chr(34) & strText & Chr(34)
End Function
'
Private Function OlkApp() As Object
' Comments : Get Outlook Application
'---------------------------------
On Error Resume Next
Dim oApp
Set oApp = GetObject(, m_strCLSID)
If oApp Is Nothing Then
Set oApp = CreateObject(m_strCLSID)
End If
'
If Not oApp Is Nothing Then
Set OlkApp = oApp
End If
Set oApp = Nothing
On Error GoTo 0
'
End Function
Public Property Get NumberType() As String
'
NumberType = m_strNumberType
End Property
'
Public Property Let NumberType(ByVal strNumberType As String)
'
m_strNumberType = strNumberType
End Property
