Match two emails (same number) with VBA and RegEx then move both mails

Question

I need VBA code that checks the email subject for a specific substring like this "Nr. 123456789".

I have this RegEx for matching: (Nr.\s1\d{8}): https://regexr.com/4i2v1

my VBA code to match one email:

    Private WithEvents olInboxItems As Items

    Private Sub Application_Startup()
     Set olInboxItems = Session.GetDefaultFolder(olFolderInbox).Items
    End Sub

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
    Dim ns As Outlook.NameSpace
    Dim MailDest As Outlook.Folder

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

    Reg1.Pattern = "(Nr.\s1\d{8})"
    If Reg1.test(Item.Subject) Then
        Set MailDest = ns.GetDefaultFolder(olFolderInbox).Folders("Admin")
        Item.Move MailDest
    End If

End Sub

Thats work for simple Mail-Subject-Check. But I must check a second mail with the same number (Nr. 123456789) but not the same subject string. The second mail arrives 5-10 mins after first mail.If i have two mails with the same number, then move both mails to another folder.

my thought for the code: After matching one Mail with RegEx, check all other mails to find the "first"-Mail. If not machting second mail, do nothing. But i dont know, how to scan all mails after matching.

Example for the subjects:

Mail 1 subject = "Lorem ipsum Nr. 100448899 dolor sit amet" Mail 2 subject = "At vero eos et accusam Nr. 100448899 no sea"

You also need to explain where you have this code at the moment, and what your current Outlook macro security settings are. — Tomalak, Jul 30 '19 at 07:22
Note that the [current patter](https://regex101.com/r/dRbTwX/1) works. Please try also running the code without the `Reg1.Glo bal = True` line. Also, escape the dot - `Reg1.Pattern = "Nr\.\s1\d{8}"`. Are you sure there is only 1 whitespace? Try `Reg1.Pattern = "Nr\.\s+1\d{8}"`. — Wiktor Stribiżew, Jul 30 '19 at 07:23
and yes im sure that after "Nr." is only 1 whitespace and then the number — boegli, Jul 30 '19 at 08:39
@WiktorStribiżew i try your solution, but doesnt work. I have the feeling that the vba-code are not active.. — boegli, Jul 30 '19 at 08:43
Just a minor note : in your regex the dot matches anything, but it seems that you want to match the character dot, so it has to be escaped in the expression : '\.' — Dali, Jul 30 '19 at 10:23
Stating the final goal gives clues but you are not at the stage of asking about it. You should limit your question to the specific problem and ask subsequent separate questions if needed. — niton, Jul 30 '19 at 11:56
Possible duplicate of [How to apply ItemAdd event to custom folder? Outlook 2010 VBA](https://stackoverflow.com/questions/34078828/how-to-apply-itemadd-event-to-custom-folder-outlook-2010-vba) — niton, Jul 30 '19 at 11:56
@niton thx - thats helped me to get the code working :) Fist Part a done. — boegli, Jul 31 '19 at 09:23

score 0 · Answer 1 · answered Aug 02 '19 at 01:17

This brute force method looks through all the items in the Inbox, until there is another RegEx match where the subject is not the same.

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)

    Dim MailDest As Folder
    Dim Reg1 As RegExp

    Dim olInbox As Folder
    Dim fldrItm As Object

    Set olInbox = Session.GetDefaultFolder(olFolderInbox)

    Set Reg1 = CreateObject("VBScript.RegExp")

    Reg1.Pattern = "(Nr.\s1\d{8})"

    If Reg1.test(Item.Subject) Then

        For Each fldrItm In olInbox.Items

            If Reg1.test(fldrItm.Subject) Then

                If fldrItm.Subject <> Item.Subject Then

                    Set MailDest = Session.GetDefaultFolder(olFolderInbox).Folders("Admin")
                    Item.Move MailDest
                    fldrItm.Move MailDest
                    Exit For

                End If
            End If
        Next
    End If

End Sub

score 0 · Accepted Answer · answered Aug 06 '19 at 18:12

Ok Thanks to all :) With the example from niton i have a good hint. Here are my Solution(improvements are welcome). Nitons code move two mails after matching second RegEx, therefore my code with substring matching:

Private WithEvents olInboxItems As Items

Private Sub Application_Startup()
     Set olInboxItems = Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)

    Dim ns As Outlook.NameSpace
    Dim MailDest As Outlook.Folder
    Dim Reg1 As Object
    Dim extractedString1 As String
    Dim extractedString2 As String

    Dim olInbox As Folder
    Dim fldrItm As Object

    Set ns = Application.GetNamespace("MAPI")
    Set Reg1 = CreateObject("VBScript.RegExp")
    Set olInbox = Session.GetDefaultFolder(olFolderInbox)

    With Reg1
        .Global = True
        .IgnoreCase = True
        .Pattern = "(Nr.\s1\d{8})"
    End With

    If Reg1.test(Item.Subject) Then

        Dim objMatches As Object
        Set objMatches = Reg1.Execute(Item.Subject)

        extractedString1 = objMatches(0)
        Debug.Print "1. Match = "
        Debug.Print extractedString1

        For Each fldrItm In olInbox.Items

            If Reg1.test(fldrItm.Subject) Then

                Dim objMatches2 As Object
                Set objMatches2 = Reg1.Execute(fldrItm.Subject)
                extractedString2 = objMatches2(0)
                Debug.Print "2. Match = "
                Debug.Print extractedString2

                If (fldrItm.Subject <> Item.Subject) Then
                    If extractedString1 = extractedString2 Then
                        Debug.Print "Alle Matches 1 und 2"
                        Debug.Print extractedString1
                        Debug.Print extractedString2

                        Set MailDest = ns.GetDefaultFolder(olFolderInbox).Folders("Admin")
                        Item.Move MailDest
                        fldrItm.Move MailDest
                        Exit For
                    End If
                End If
            End If
        Next
    End If
End Sub

Match two emails (same number) with VBA and RegEx then move both mails

2 Answers2