To remove duplicate messages from the Inbox

Code Sample

' Code sample by Ulfar Erlingsson [ulfar@greenborder.com] ' Moves duplicate items from the Inbox to a Dupes folder ' created under the Inbox Private Sub MoveDuplicates() Dim myDate As Date Dim dupDate As Date Dim mySubject As String Dim dupSubject As String Dim mySender As String Dim dupSender As String Dim myItems As Items Dim myInbox as MAPIFolder Dim myItem As Object Dim dupItem As Object Set myOlApp = CreateObject("Outlook.Application") Set myNameSpace = myOlApp.GetNamespace("MAPI") Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox) Set myItems = myInbox.Items On Error Resume Next Set dupsFolder = myInbox.Folders("Dupes") If Err <> 0 Then Set dupsFolder = myInbox.Folders.Add("Dupes") Err.Clear End If myItems.Sort "[Subject]", False Set myItem = myItems.GetFirst While TypeName(myItem) <> "Nothing" If TypeName(myItem) = "MailItem" Then myDate = myItem.ReceivedTime mySubject = myItem.Subject mySender = myItem.SenderName If Err = 0 Then Set dupItem = myItems.GetNext dupDate = dupItem.CreationTime If TypeName(dupItem) = "MailItem" Then dupSubject = dupItem.Subject dupSender = dupItem.SenderName End If If TypeName(dupItem) = "MailItem" _ And mySubject = dupItem.Subject _ And mySender = dupItem.SenderName _ And DateDiff("n", myDate, dupDate) < 2 Then dupItem.Move dupsFolder Else Set myItem = dupItem End If Else Err.Clear Set myItem = myItems.GetNext End If End If Wend Set myItem = Nothing Set dupItem = Nothing Set myItems = Nothing Set myInbox = Nothing Set myNameSpace = Nothing Set myOlApp = Nothing End Sub  

Notes

The use of SenderName will trigger an address book security prompt in some environments. To avoid this, you might instead use the Redemption method to return the sender's address.

More Information

• To get the sender's address from a Microsoft Outlook mail message