Forward Outlook Email by Filtering using Macro Rule

[Alfie Panelo]

Hello All,

I'm having trouble coding Regex with vba

Can anyone help me with missing part to make the Outlook VBA script below work?

What I'm trying to do is filter the email body that contains a less than symbol <, it will forward to a specific email address.

Here is so far what I have.

Public Sub FWItem(Item As Outlook.mailitem)
Dim Email As Outlook.mailitem
Dim Matches As Variant
Dim RegExp As Object
Dim Pattern As String

Set RegExp = CreateObject("VbScript.RegExp")

If TypeOf Item Is Outlook.mailitem Then

Pattern = "(\s[<]\s)"
With RegExp
.Global = False
.Pattern = Pattern
.IgnoreCase = True
Set Matches = .Execute(Item.Body)
End With

If Matches.Count > 0 Then
Debug.Print Item.subject ' Print on Immediate Window
Set Email = Item.Forward
Email.subject = Item.subject
Email.Recipients.Add "alias@domain.com"
Email.Save
Email.Send

End If
End If

Set RegExp = Nothing
Set Matches = Nothing
Set Email = Nothing
Set Item = Nothing
End Sub


Here is a sample email text:

"That was fast! It only took < 60 seconds to reboot the modem."

If there is a space between < and 60, it will forwarded to my email but if there are no space, it won't.

Thank you,

 

[Diane Poremsky]

Do you want both <60 and < 60 to be forwarded?
Try adding ? for 'optional':
Pattern = "(\s[<]\s?)"
or removing the second \s:
Pattern = "(\s[<])"

 

[Alfie Panelo]

Hello Diane,

Thank you for your swift response. Yes, I want both <60 and < 60 to be forwarded. Will try your suggestion and will keep you posted.

Regards,

 

[Alfie Panelo]

Hi Diane,

I applied your suggestion on my Macro Rule. Both are now working. However, even though there is no < symbol on the email body, it was still forwarding to my email.

Regards,

 

[Diane Poremsky]

Even with this pattern? Pattern = "(\s[<])" or try Pattern = "(\s<)"

 

[Diane Poremsky]

Ah... I think i might know... it looks like it is finding < in the html code. so without the \s, it's finding everything. Is there anything else unique in the message you can look for, to help restrict it to these specific messages?

 

[Alfie Panelo]

Hello Diane,

Thank you for helping me here. Only < that I need to filter on the email body.

Regards,

 

[Diane Poremsky]

if you add msgbox Item.Body near the top of the code, you'll see it is using the raw body - not just what you see on the screen. Converting the message to plain text might work but if the messages you need to check are always plain text, you can check for the format first, then skip any that are html.

If TypeOf Item Is Outlook.mailitem Then
Item.BodyFormat = olFormatPlain
strBody = item.body 

Pattern = "(\s[<]\s)"
With RegExp
.Global = False
.Pattern = Pattern
.IgnoreCase = True
Set Matches = .Execute(strBody)
End With

or, if the message you need to forward are already plain text, use this:
If TypeOf Item Is Outlook.mailitem And Item.BodyFormat = olFormatPlain Then


BTW, to make it easier to test without sending messages and running rules, use this little stub macro - select a message and then run this macro - it will process the current item using the run a script macro. I usually change the script I'm testing to display the message, rather than sending it, so i don't spam myself.

Sub RunScript()
Dim objApp As Outlook.Application
Dim objItem As MailItem
Set objApp = Application
Set objItem = objApp.ActiveExplorer.Selection.Item(1)

'macro name you want to run goes here
FWItem objItem

End Sub

 

[Alfie Panelo]

Hello Diane,

Will try this and will keep you posted.

Thank you,

 

[Alfie Panelo]

Hi Diane,

I tried what you have suggested above. The good thing is, all email that I received is now converted to Plain Text but even the mail body contains <, it will now not forwarded to my email.

BTW, i used the code below for my pattern:

If TypeOf Item Is Outlook.mailitem and Item.BodyFormat = olFormatPlain Then

strBody = item.body

Pattern = "(\s[<]\s)"
With RegExp
.Global = False
.Pattern = Pattern
.IgnoreCase = True
Set Matches = .Execute(strBody)
End With

Also, I tried this code but, when the email converted to Plain text, there are too many < in the email body.

If TypeOf Item Is Outlook.mailitem Then

Item.BodyFormat = olFormatPlain
strBody = item.body

Pattern = "(\s[<]\s)"
With RegExp
.Global = False
.Pattern = Pattern
.IgnoreCase = True
Set Matches = .Execute(strBody)
End With

FYI, we are using HTML Format.

Thank you,

 

[Diane Poremsky]

so when you convert to plain text, it wraps the url in <> ? It worked in my quickie test.

It looks like you have two choices - use rules or the script to filter the mail so the only mail processed by the script are ones that might have the < in the body or expand the pattern if the phrase is always the same.

Pattern = "(\s[<]\s?[0-9]*)" should pick up anything from <1 to < 1000 (to infinity). This definitely won't get the urls.

 

[Diane Poremsky]

This seems to be working ok here in my limited tests - i have it popping up a message box if the macro runs but doesn't have the < in the body. I also limited the number to 2 digits - it should work with any number of digits but won't find single digits.

Public Sub FWItem(Item As Outlook.MailItem)
Dim Email As Outlook.MailItem
Dim Matches As Variant
Dim RegExp As Object
Dim Pattern As String

Set RegExp = CreateObject("VbScript.RegExp")

If TypeOf Item Is Outlook.MailItem Then

Pattern = "(\s[<]\s?[0-9]{2})"
With RegExp
.Global = False
.Pattern = Pattern
.IgnoreCase = True
Set Matches = .Execute(Item.Body)
End With

If Matches.Count > 0 Then
Debug.Print Item.Subject ' Print on Immediate Window
Set Email = Item.Forward
Email.Subject = Item.Subject
Email.Recipients.Add "alias@domain.com"
Email.Save
Email.Display
Else
MsgBox "no match"

End If
End If

Set RegExp = Nothing
Set Matches = Nothing
Set Email = Nothing
Set Item = Nothing
End Sub

 

[Alfie Panelo]

Hi Diane,

Thank you for this. I will try this again and will keep you posted.

I appreciate your help here.

Regards,

 

[mlpetrozelli]

Diane, ANY help is greatly appreciated as I have a similar request from an Outlook 2013 user that wants me to create a script that can be used by an Outlook rule that would detach a file from an e-mail and store that file in a specific location. I've done tons of searches, enabled macros and setup a test rule:
From Specific email address
Which has an attachment
Run script

But I think my script is wrong because nothing ever happens (copied and edited from internet):


Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)

On Error GoTo ErrorHandler

'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item

'Change variables to match need. Comment or delete any part unnecessary.
If (Msg.SenderName = "Michael") And _
(Msg.Subject = "test") And _
(Msg.Attachments.Count >= 1) Then

'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Att As String

'location to save in. Can be root drive or mapped network drive.
Const attPath As String = "\\servername\subfolder"


' save attachment
Set myAttachments = item.Attachments
Att = myAttachments.item(1).DisplayName
myAttachments.item(1).SaveAsFile attPath & Att

' mark as read
Msg.UnRead = False
End If
End If


ProgramExit:
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
Sub myRuleMacro(item As Outlook.MailItem)
End Sub
End Sub


End Sub

I'm not great with scripting, so not sure if I need to include quotes, extra slashes, etc. for users and locations. Am I missing something here??

 

[Diane Poremsky]

Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)

This part tells me it's an item add rule and will run automatically when outlook starts. it works by watching the folder set here: Set Items = objNS.GetDefaultFolder(olFolderInbox).Items - in this case, the default inbox.

The macro should error on this - you have a sub within a sub.
--snip--
Sub myRuleMacro(item As Outlook.MailItem)
End Sub
End Sub


End Sub

The run a script rule at Save and Rename Outlook Email Attachments should work - create the conditions in the rule and send them to the script. you need to change the save to path and if you only want to save certain attachment types, tweak it for that too. Oh, and remove the part that changes the saved file name.

 

[Diane Poremsky]

This should work - sometimes outlook will hang or fail with network paths - you might need to use a mapped drive path.

Public Sub saveAttachtoDiskRule(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim file As String

saveFolder = "\\Servername\foldername\test\"

' after you confirm it work without errors
' remove the ' from the next line
' On Error Resume Next

For Each objAtt In itm.Attachments
file = saveFolder & objAtt.DisplayName
objAtt.SaveAsFile file

Set objAtt = Nothing
Next
 
End Sub

 

[mlpetrozelli]

This should work - sometimes outlook will hang or fail with network paths - you might need to use a mapped drive path.

Public Sub saveAttachtoDiskRule(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim file As String

saveFolder = "\\Servername\foldername\test\"

' after you confirm it work without errors
' remove the ' from the next line
' On Error Resume Next

For Each objAtt In itm.Attachments
file = saveFolder & objAtt.DisplayName
objAtt.SaveAsFile file

Set objAtt = Nothing
Next
 
End Sub

Diane, just so I'm understanding you...is ONLY this code needed in my script along with my previous rules I mentioned in order to work properly? Oh, and does the code go in the module or 'thisoutlooksession' script? (sorry, not a VB guy!)

 

[Diane Poremsky]

Yes, you only need this code - I recommend putting it in a module, but it will work from thisoutlooksession.

 

[mlpetrozelli]

Yes, you only need this code - I recommend putting it in a module, but it will work from thisoutlooksession.

If I do a "run rules now" nothing happens at all, no files move anywhere, regardless of whether I do it drive letter or \\servername\folder. Anything I could be overlooking?

 

[mlpetrozelli]

Is there any way to see where it fails? I quickly see the file transfer animation in a blink, but it's not actually copying anything nor does it give an error.