Delete older emails with same subject line

[brettdj]

Hi Malcom

I had a crack at this below, the code moves the older messages into a subfolder called "Old". I'm wary whether the code always moves the correct old message with this line
olInbox.Items(olItem.Subject).Move olDupe

In my testing it worked but.....

The code uses a Dictionary Object to hold the subject name and sender (so it wont cull messages from different senders with the same subject). I've used early binding so you need to set a reference to Microsoft Scripting Runtime.

I think that the Find method would be a superior way of doing this speedwise, I'll have a play


Cheers

Dave

Sub KillDupes()
'Needs a reference to Microsoft Scripting Runtime
    Dim olSession As Outlook.Application, olNamespace As NameSpace
    Dim olInbox As Outlook.MAPIFolder, olDupe As Outlook.MAPIFolder
    Dim olItem As MailItem
    Dim olDict As Dictionary
    Set olSession = New Outlook.Application
    Set olDict = New Scripting.Dictionary
    Set olNamespace = olSession.GetNamespace("MAPI")
    Set olInbox = olNamespace.GetDefaultFolder(olFolderInbox)
    On Error Resume Next
    Set olDupe = olInbox.Folders("Old")
    If Err <> 0 Then Set olDupe = olInbox.Folders.Add("Old")
   On Error GoTo 0
   For Each olItem In olInbox.Items
      If TypeName(olItem) = "MailItem" Then
         If olDict.Exists(olItem.Subject & olItem.SenderName) Then
            'if the subject exists test to see which message is newer
               If olItem.ReceivedTime > olDict(olItem.Subject & olItem.SenderName) Then
                  olInbox.Items(olItem.Subject).Move olDupe
                  olDict.Remove olItem.Subject & olItem.SenderName
                  olDict.Add olItem.Subject & olItem.SenderName, olItem.ReceivedTime
                  Else
                  ' move the current item if it is older
                  olItem.Move olDupe
               End If
               Else
               olDict.Add olItem.Subject & olItem.SenderName, olItem.ReceivedTime
         End If
     End If
Next
    Set olDict = Nothing
    Set olSession = Nothing
End Sub