How to Automatically Move an Email to a Folder if it Contains 10 digits in the subject line

Question

I would like to make it so if an email comes in with a phone number in the subject line (so 10 numerical digits) then the system automatically moves it to a folder called "Texting."

User Reidacus asked a very similar question here: Move incoming mail to folders with RegEx in a rule

But I can't get it to work for me. When the email comes in it just sits in my inbox. I am very new the VBA and (sorry), I don't have a clue what I'm doing. Do I need to install anything special into my system to get this to work?

Here is my adapted code (note: in the real code I have my real email address)

Sub filter(Item As Outlook.MailItem)
    Dim ns As Outlook.NameSpace
    Dim MailDest As Outlook.Folder
    Set ns = Application.GetNamespace("MAPI")
    Set Reg1 = CreateObject("VBScript.RegExp")

    Reg1.Global = True
    Reg1.Pattern = "([\d][\d][\d][\d][\d][\d][\d][\d][\d][\d])"
    If Reg1.Test(Item.Subject) Then
        Set MailDest = ns.Folders("firstname.lastname@email.ca").Folders("Inbox").Folders("Texting")
        Item.Move MailDest
    End If
End Sub

Did you follow any of the tests done in the linked question - i.e. put a `MsgBox` in to ensure that the script is being called? — YowE3K, Dec 31 '16 at 00:48
Since you are very new to VBA you may not be aware you call this with the "Run a script" option in a rule. — niton, Dec 31 '16 at 01:48

score 0 · Answer 1 · edited May 23 '17 at 12:01

In order for your Sub Filter to run everytime a new emails comes in, you need to add an "event listener", by adding the code below to the ThisOutlookSession module (this code is taken from home, here on SO : How do I trigger a macro to run after a new mail is received in Outlook? )

In order for this code to take affect, you must Restart Outlook.

ThisOutlookSession Module Code

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()

Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace

Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")

' get default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items

End Sub


Private Sub Items_ItemAdd(ByVal item As Object)

On Error GoTo ErrorHandler

Dim Msg As Outlook.MailItem

If TypeName(item) = "MailItem" Then
    Set Msg = item

    ' Call your custom-made Filter Sub
    Call filterNewMail_TenDig(item)
End If

ProgramExit:
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description

Resume ProgramExit

End Sub

Now, you only need to make the following modifications to your Module code. Using ns.GetDefaultFolder(olFolderInbox) will get you the default "Inbox" folder for the current profile (read here at MSDN link ).

Sub filterNewMail_TenDig Code

Sub filterNewMail_TenDig(item As Outlook.MailItem)

    Dim ns As Outlook.NameSpace
    Dim MailDest As Outlook.Folder

    Set ns = Outlook.Application.GetNamespace("MAPI")
    Set reg1 = CreateObject("VBScript.RegExp")

    With reg1
        .Global = True
        .IgnoreCase = True
        .Pattern = "\d{10,10}" ' Match any set of 10 digits
    End With

    If reg1.Test(item.Subject) Then
        Set MailDest = ns.GetDefaultFolder(olFolderInbox).Folders("Texting")
        item.Move MailDest
    End If

End Sub

How to Automatically Move an Email to a Folder if it Contains 10 digits in the subject line

1 Answers1