Outlook 2010 Forward Outlook Email by Filtering using Macro Rule

Alfie Panelo

Member
Outlook version
Outlook 2010 64 bit
Email Account
Exchange Server
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,
 

Alfie Panelo

Member
Outlook version
Outlook 2010 64 bit
Email Account
Exchange Server
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

Member
Outlook version
Outlook 2010 64 bit
Email Account
Exchange Server
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

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Even with this pattern? Pattern = "(\s[<])" or try Pattern = "(\s<)"
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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

Member
Outlook version
Outlook 2010 64 bit
Email Account
Exchange Server
Hello Diane,

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

Regards,
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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.

Code:
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.

Code:
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

Member
Outlook version
Outlook 2010 64 bit
Email Account
Exchange Server
Hello Diane,

Will try this and will keep you posted.

Thank you,
 

Alfie Panelo

Member
Outlook version
Outlook 2010 64 bit
Email Account
Exchange Server
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

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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.

Code:
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

Member
Outlook version
Outlook 2010 64 bit
Email Account
Exchange Server
Hi Diane,

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

I appreciate your help here.

Regards,
 

mlpetrozelli

New Member
Outlook version
Outlook 2013 64 bit
Email Account
Office 365 Exchange
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

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
This should work - sometimes outlook will hang or fail with network paths - you might need to use a mapped drive path.

Code:
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

New Member
Outlook version
Outlook 2013 64 bit
Email Account
Office 365 Exchange
This should work - sometimes outlook will hang or fail with network paths - you might need to use a mapped drive path.

Code:
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

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Yes, you only need this code - I recommend putting it in a module, but it will work from thisoutlooksession.
 

mlpetrozelli

New Member
Outlook version
Outlook 2013 64 bit
Email Account
Office 365 Exchange
Yes, you only need this code - I recommend putting it in a module, but it will work from thisoutlooksession.
upload_2017-6-6_14-37-13.png

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

New Member
Outlook version
Outlook 2013 64 bit
Email Account
Office 365 Exchange
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.
 

Similar threads

Top