Outlook 2007 Search Through E-Mail

[LMS]

Recently we came up with the way to move an email coming from Microsoft as a non-delivery to a folder I want to move it to, as I can select a lot and move them without having to find the folder and drag it.

So when I open that email, it simply in the note field it has the email that did not work.

Is there a macro that I select an email, just select it, and then run the macro and it searches all contact folders and subfolders etc. to find the contact that comes with that email.

That would be great. Thanks.

 

[Diane Poremsky]

I have the macro here that does adds a category to contacts that bounce - http://www.slipstick.com/developer/categorize-contacts-bad-addresses/ - it only checks the default contacts folder though.

 

[LMS]

Your macro not for selecting an email address in the note field of a email from some other place....and I just want to have it open the contact...not do anything else.....and ideas please?

 

[Forum Admin]

change this block to do whatever you want

myItem.Categories = myItem.Categories & ";Delete" 
 
myItem.Save

to open the contact, use
myitem.display

 

[LMS]

Your macro not for selecting an email address in the note field of a email from some other place....and I just want to have it open the contact...not do anything else.....and ideas please?

 

[LMS]

Where do i put the line code: myitem.display? And will this work selecting an email address? And if so, how search in the sub folders and the sub sub folders all at one time?

 

[Diane Poremsky]

The macro works on the selected message, you don't select the email address in the message, the regex looks for the first address.

Change myItem.Save to myItem.display to open it.

 

[LMS]

Thanks but that is not what I need. As the message is from Microsoft not the email address it did not go to. I want to find the contact that is the email address in the message as the message says that email address did receive my email. Anyway to do this?

 

[Forum Admin]

did you look at the screenshot on that page with the example of an NDR? Does your NDR have the email address in the message body like in the screenshot? The text can be different - as long as the email address is in the body, this line in the code will find it: .Pattern = "(([\w-\.]*\@[\w-\.]*)\s*)"

The code looks for the first email address in the body.

 

[LMS]

I did the following per the NDR you mentioned....tested it to a contact in the Contact folder, and it opened up the contact....so what can we now change so it searches all contact folders, subfolders, and sub sub folders please?

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
Dim myItem As contactItem
Set Selection = Application.ActiveExplorer.Selection
Set myContacts = Session.GetDefaultFolder(olFolderContacts).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)
'If TypeName(myItem) = "ContactItem" Then
' If Not TypeName(myItem) = "Nothing" Then
'myItem.Categories = myItem.Categories & ";Delete"
' Debug.Print strAddress & " Delete"
myItem.Display
'End If
'End If
Next
End If
Next
End Sub

 

[LMS]

The following code is that I had it search a specific sub sub folder called "Sub Test" which is below the sub folder called "Test", and it works to the folder...but how do we do for all sub and sub sub folders....or if I want to add another folder to this list, how do I just add another folder or more folders as I tried it just putting the same words to another folder after the &...but that did not work...so I can add all folders to it if that's the only way to do it...so need to search more than one folder: Thanks much

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").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

 

[Diane Poremsky]

This is one reason we recommend using Categories and views over a lot of folders.

I don't know if its better to use a GetFolder sub or a different method to find the contact.

 

[LMS]

I would like to change the code to search all folders or the names of the folders I add. How to do it either way please.

 

[LMS]

At my office needing do it ...any update? As I have a lot of emails back etc.

 

[Forum Admin]

You need to use something like

set objFolder =Session.GetDefaultFolder(olFolderContacts)

For Each fld in objFolder.Folders
Set myContacts = objFolder.Folders.Items
Set myItem = myContacts.Find("[Email1Address]=" & strAddress)
Next

if you have contacts\subfolder\subfolder format, it's more complicated because the above code only looks at the folders under contacts.

The Private Sub LoopFolders code sample at http://www.vboffice.net/en/developers/expand-all-folders could be used but it needs some editing to work in your search and i definitely don't have time to do that.

 

[LMS]

Here is the code that I use for sub sub folders but the same code for sub folders.....where do I put what you wrote and were ..and what do I delete....can you just adjust the code for me please:

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").Folders("Sub Sub Test").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

 

[LMS]

Update re my last question?

 

[Diane Poremsky]

Try something like this - I can't test it because i don't have subfolders, but it should work.

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 
 
Dim fld as Outlook.folder 
Dim objFolder as Outlook.folder 
 
Set Selection = Application.ActiveExplorer.Selection 
 
' parent folder 
Set objFolder = Session.GetDefaultFolder(olFolderContacts) 
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 
 
For Each fld in objFolder.Folders 
Set myContacts = objFolder.Folders.Items 
 
Set myItem = myContacts.Find("[Email1Address]=" & strAddress) 
myItem.Display 
 
Next 
 
Next 
 
End If 
Next 
End Sub

 

[LMS]

There is an error where the following line turns yellow and it does not do it:

Set myContacts = objFolder.Folders.Items

 

[Diane Poremsky]

What's the error message? It's most likely something with the line before it:
For Each fld in objFolder.Folders

try changing these lines to
Dim fld as Object
Dim objFolder as Object