Sub FindEmailAddressInContacts()
Dim objApp As Application
Dim objNS As NameSpace
Dim objContacts As MAPIFolder
Dim colItems As Items
Dim objItem As Object
Dim strAddress As String
Dim strWhere As String
Dim blnFound As Boolean
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objContacts = objNS.GetDefaultFolder(olFolderContacts)
strWhere = "[Email1Address] <> vbNullString " & _
"Or [Email2Address] <> vbNullString " & _
"Or [Email3Address] <> vbNullString "
Set colItems = objContacts.Items.Restrict(strWhere)
strAddress = InputBox("Find an Address in Contacts")
If strAddress <> "" Then
colItems.SetColumns ("Email1Address, Email2Address, Email3Address")
For Each objItem In colItems
If TypeName(objItem) = "ContactItem" Then
If InStr(objItem.Email1Address, strAddress) > 0 Then
objItem.Display
blnFound = True
Exit For
ElseIf InStr(objItem.Email2Address, strAddress) > 0 Then
objItem.Display
blnFound = True
Exit For
ElseIf InStr(objItem.Email3Address, strAddress) > 0 Then
objItem.Display
blnFound = True
Exit For
End If
End If
Next
End If