Here's a script that takes advantage of sorting emails to check for duplicates much more efficiently.
There's no need to maintain a giant dictionary of every email you've seen if you are processing emails in a deterministic order (e.g. received date). Once the date changes, you know you'll never see another email with the prior date, therefore, they won't be duplicates, so you can clear your dictionary on each date change.
This script also takes into account the fact that some items use an HTMLBody for the full message definition, and others don't have that property.
Sub DeleteDuplicateEmails()
Dim allMails As Outlook.Items
Dim objMail As Object, objDic As Object, objLastMail As Object
Dim olFolder As Folder, olDuplicatesFolder As Folder
Dim strCheck As String
Dim received As Date, lastReceived As Date
Set objDic = CreateObject("scripting.dictionary")
With Outlook.Application.GetNamespace("MAPI")
Set olFolder = .PickFolder
End With
If olFolder Is Nothing Then Exit Sub
On Error Resume Next
Set olDuplicatesFolder = olFolder.Folders("Duplicates")
On Error GoTo 0
If olDuplicatesFolder Is Nothing Then Set olDuplicatesFolder = olFolder.Folders.Add("Duplicates")
Debug.Print "Sorting " & olFolder.Name & " by ReceivedTime..."
Set allMails = olFolder.Items
allMails.Sort "[ReceivedTime]", True
Dim totalCount As Long, index As Long
totalCount = allMails.count
Debug.Print totalCount & " Items to Process..."
lastReceived = "1/1/1987"
For index = totalCount - 1 To 1 Step -1
Set objMail = allMails(index)
received = objMail.ReceivedTime
If received < lastReceived Then
Debug.Print "Error: Expected emails to be in order of date recieved. Previous mail was " & lastReceived _
& " current is " & received
Exit Sub
ElseIf received = lastReceived Then
' Might be a duplicate track mail contents until this recieved time changes.
' Add the last mail to the dictionary if it hasn't been tracked yet
If Not objLastMail Is Nothing Then
Debug.Print "Found multiple emais recieved at " & lastReceived & ", checking for duplicates..."
objDic.Add GetMailKey(objLastMail), True
End If
' Now check the current mail item to see if it's a duplicate
strCheck = GetMailKey(objMail)
If objDic.Exists(strCheck) Then
Debug.Print "Found Duplicate: """ & objMail.Subject & " on " & lastReceived
objMail.Move olDuplicatesFolder
DoEvents
Else
objDic.Add strCheck, True
End If
' No need to track the last mail, since we have it in the dictionary
Set objLastMail = Nothing
Else
' This can't be a duplicate, it has a different date, reset our dictionary
objDic.RemoveAll
lastReceived = received
' Keep track of this mail in case we end up needing to build a dictionary
Set objLastMail = objMail
End If
' Progress update
If index Mod 10 = 0 Then
Debug.Print index & " Remaining..."
End If
DoEvents
Next
Debug.Print "Finished moving Duplicate Emails"
End Sub
And the helper function referenced above for "uniquely identifying" an email. Adapt as needed, but I think if the subject and full body are the same, there's no point in checking anything else. Also works for calendar invites, etc.:
Function GetMailKey(ByRef objMail As Object) As String
On Error GoTo NoHTML
GetMailKey = objMail.Subject & objMail.HTMLBody
Exit Function
BodyKey:
On Error GoTo 0
GetMailKey = objMail.Subject & objMail.Body
Exit Function
NoHTML:
Err.Clear
Resume BodyKey
End Function
