How to delete old emails when a new email with the same subject is being received

Question

I'm Having trouble deleting Emails with same subject line but keeping the newly received Email on Outlook-vba

Does anyone have any ideas on how to do that?

Answer 1

You can work with Dictionary Object to Store Items.Subject while you measure the received Item.ReceivedTime with Item.ReceivedTime in your Inbox.Items

---

_{Dictionary in VBA is a collection-object: you can store all kinds of things in it: numbers, texts, dates, arrays, ranges, variables and objects, Every item in a Dictionary gets its own unique key and With that key you can get direct access to the item (reading/writing).}

---

Now to Automate the process - Try working with Application.Startup Event (Outlook) And Items_ItemAdd Event (Outlook)

_{Items.ItemAdd Event Occurs when one or more Items are added to the specified collection. This event does not run when a large number of items are added to the folder at once.}

---

Code Example

Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
    Dim olNs As Outlook.NameSpace
    Dim Inbox  As Outlook.MAPIFolder

    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then
        RemoveDupEmails Item ' call sub
    End If
End Sub

Private Sub RemoveDupEmails(ByVal Item As Object)
    Dim olNs As Outlook.NameSpace
    Dim Inbox  As Outlook.MAPIFolder
    Dim DupItem As Object
    Dim Items As Outlook.Items
    Dim i As Long

    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items

    Debug.Print Item.ReceivedTime ' Immediate Window

    Set DupItem = CreateObject("Scripting.Dictionary")
    Set Items = Inbox.Items

    Items.Sort "[ReceivedTime]"

    For i = Items.Count To 1 Step -1
        DoEvents
        If TypeOf Items(i) Is MailItem Then
            Set Item = Items(i)

            If Item.ReceivedTime >= Items(i).ReceivedTime Then

                If DupItem.Exists(Item.Subject) Then
                    Debug.Print Item.Subject ' Immediate Window
                    'Item.Delete ' UnComment to delete Item
                Else
                    DupItem.Add Item.Subject, 0
                End If

            End If

        End If
    Next i

    Set olNs = Nothing
    Set Inbox = Nothing
    Set DupItem = Nothing
    Set Items = Nothing
End Sub

---