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
Dim strAddress As String
Dim myContacts As Items
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
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
Dim myItem As contactItem
For Each oContact In oParent.Items
Set myItem = oContacts.Find("[Email1Address]=" & strAddress)
myItem.Display
Next
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
Call processFolder(oFolder)
Next
End If
End Sub