Outlook 2007 Macro Search Contacts

[lms]

Through someone else techically, I have this code that when I receive an email message, if the message area has an email address in it, this code recognizes the first email address in the body field of the message, and searches automatically for the contact in my list of contacts that has the email address, and it opens up the contact. The purposes of this is sometimes I send and an email message and receive a message back that a certain email was not delivered, and in the email I receive back, it shows that email address not delivered, so I can find the contact that is a part of that.

But the original code only searches the folder Contacts....not all other sub folders and sub sub folders of the Contact folder. So I changed the one line which is " Set myContacts = Session.GetDefaultFolder(olFolderContacts).Items" to a specifc sub sub folder using the following line: "Set myContacts = Session.GetDefaultFolder(olFolderContacts).Folders("Test").Folders("Sub Test").Folders("Sub Sub Test").Items", and it searches that particular sub sub folder.
So does anyone know quickly what to change so that it searches all Contacts, sub folders and sub sub folders? And if the way to do it, is I need to add to it each sub folder and sub sub folder name, I would like to know how to do that.

Thanks very much and here is the full code.

[CODE][Sub GetValueUsingRegEx32()
Dim obj As Object
Dim Selection As Selection
Dim olMail As Object 'Outlook.MailItem
Dim Reg1 As Object
Dim M1 As Object
Dim M As Object
Dim strAddress As String
Dim myContacts As Items
Dim myItem As contactItem


Set Selection = Application.ActiveExplorer.Selection
Set myContacts = Session.GetDefaultFolder(olFolderContacts).Folders("Test").Folders("Sub Test 2").Folders("Sub Sub Test 2").Items

For Each obj In Selection
Set olMail = obj

Set Reg1 = CreateObject("VBScript.RegExp")
With Reg1
.Pattern = "(([\w-\.]*\@[\w-\.]*)\s*)"
.IgnoreCase = True
.Global = False
End With

If Reg1.TEst(olMail.Body) Then

Set M1 = Reg1.Execute(olMail.Body)
For Each M In M1
strAddress = M.SubMatches(1)
Debug.Print strAddress

Set myItem = myContacts.Find("[Email1Address]=" & strAddress)

myItem.Display

Next

End If
Next
End Sub/CODE]

[lms]

Any update from someone please? I would appreciate the help.

[skatonni]

You will find code for "Looping recursively through folders and subfolders" here.

http://www.vboffice.net/sample.html?lang=en&mnu=2&smp=12&cmd=showitem

[westconn1]

to search all sub folders you need a recursive procedure, you do not need to know the names of the folders
the recursive procedure must initially be called from other procedure, passing the root folder


Sub subfolds(fold As MAPIFolder)
Dim subf As MAPIFolder

' your code to search contacts within folder
' change this line to
Set mycontacts = fold.Items

' if contact is found
' assuming you do not want to continue searching
If Not myItem Is Nothing Then
myItem.Display
fnd = True
Exit Sub
End If

For Each subf In fold.Folders
subfolds subf
If fnd Then Exit Sub
Next


End Sub
Sub strt()
Dim f As MAPIFolder
fnd = false
Set f = GetNamespace("mapi").GetDefaultFolder(olFolderContacts)
subfolds f
End Subin this case fnd is a boolean variable declared at the top of the code page in the general section
this is untested and may require some changes, also i am not certain that myitem is nothing if it not found
if you want to find all contacts that may match the street address, you will need to add each contact to an array of contacts for later use, the array would need to be declared in the general section of the code page, and redimensioned as required, the fnd variable would no longer be used

[lms]

Thanks to both. Given I am not a technical expert, can you please show me what to change to the code I gave you relative to the areas you showed me, so I have the full code to test as I want to search for the contact that has the email address that showed up in the email note field that I received. .

That would be wonderful. Thanks so much!

[westconn1]

i thought i had give a good solution above, better you try to modify the code yourself, so you can learn something, then post your attempt indicating what problems you need help with

forums are to help you learn, not a free programming service, if you want it all done for you, try rentacoder

[lms]

To All: Here is the code that does what I mentioned


Dim strAddress As String
Sub GetValueUsingRegEx3()
Dim obj As Object
Dim Selection As Selection
Dim olMail As Object 'Outlook.MailItem
Dim Reg1 As Object
Dim M1 As Object
Dim M As Object

Set objNS = Application.GetNamespace("MAPI")
Set Selection = Application.ActiveExplorer.Selection

For Each obj In Selection
Set olMail = obj
Set Reg1 = CreateObject("VBScript.RegExp")
With Reg1
.Pattern = "(([\w-\.]*@[\w-\.]*)\s*)"
.IgnoreCase = True
.Global = False
End With

If Reg1.test(olMail.Body) Then

Set M1 = Reg1.Execute(olMail.Body)
For Each M In M1
strAddress = M.SubMatches(1)
Debug.Print strAddress & " " & Time
processFolder (objNS.GetDefaultFolder(olFolderContacts))

Next

End If
Next
End Sub

Private Sub processFolder(ByVal oParent As Outlook.MAPIFolder)
Dim oFolder As Outlook.MAPIFolder
Dim oContact As Outlook.ContactItem
On Error Resume Next
For Each oContact In oParent.Items
If oContact.Email1Address = strAddress Then
oContact.Display
End If
Next
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
Call processFolder(oFolder)
Next
End If
End Sub

[westconn1]

this is a good result, the only thing i can see, is that it always searches all contact folders even if a match is found, if you want to stop searching after a match, see my previous example for exiting the recursion, using a global boolean