Delete duplicate e-mails in Outlook 2003

[MakItWork]

I'm looking for a free way to delete duplicate e-mails in Outlook 2003. I've seen some software for sale, but on 1/14/2005 pbj75 posted some Visual Basic code that flagged duplicate contacts and it seems like there should be a way to do the same thing to e-mails. I haven't had any luck modifying the duplicate contact code below. Help.

Public Sub deleteduplicatecontacts()
Dim oldcontact As ContactItem, newcontact As ContactItem, j As Integer
Set mynamespace = GetNamespace("MAPI")
Set myfolder = mynamespace.GetDefaultFolder(olFolderContacts)
Set myitems = myfolder.Items
myitems.Sort "[File As]", olDescending
totalcount = myitems.Count
j = 1
While ((j < totalcount) And (myitems(j).Class <> olContact))
j = j + 1
Wend
Set oldcontact = myitems(j)
For i = j + 1 To totalcount
If (myitems(i).Class = olContact) Then
Set newcontact = myitems(i)
'if((newcontact.lastmodificationtime = oldcontact.lastmodificationtime) and
If ((newcontact.LastNameAndFirstName = oldcontact.LastNameAndFirstName) And _
(newcontact.FileAs = oldcontact.FileAs) And _
(newcontact.PagerNumber = oldcontact.PagerNumber) And _
(newcontact.HomeTelephoneNumber = oldcontact.HomeTelephoneNumber) And _
(newcontact.BusinessTelephoneNumber = oldcontact.BusinessTelephoneNumber) And _
(newcontact.BusinessAddress = oldcontact.BusinessAddress) And _
(newcontact.Email1Address = oldcontact.Email1Address) And _
(newcontact.HomeAddress = oldcontact.HomeAddress) And _
(newcontact.CompanyName = oldcontact.CompanyName)) Then
'use FTPSite as a flag to mark duplicates
newcontact.FTPSite = "DELETEMESEYMOUR"
newcontact.Save
End If
Set oldcontact = newcontact

End If
Next i
End Sub

 

[MakItWork]

After 2 days of trial and error, the following looks like it's going to work.

Sub GetFolderContents()

Dim objOutlook As New Outlook.Application
Dim objNameSpace As NameSpace
Dim objFolder As MAPIFolder
Dim oldcontact As MailItem
Dim newcontact As MailItem
Dim i As Integer

Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set objFolder = _
objNameSpace.GetDefaultFolder(olFolderInbox) 'Access the Inbox
Set myitems = objFolder.Items
myitems.Sort "[Received]", olAscending
totalcount = myitems.Count
j = 1

While ((j < totalcount) And (myitems(j).Class <> olMail))
j = j + 1
Wend

Set oldcontact = myitems(j)

For i = j + 1 To totalcount
If (myitems(i).Class = olMail) Then
Set newcontact = myitems(i)
If ((newcontact.SenderName = oldcontact.SenderName) And _
(newcontact.To = oldcontact.To) And _
(newcontact.Subject = oldcontact.Subject) And _
(newcontact.ReceivedTime = oldcontact.ReceivedTime)) Then
' newcontact.Categories = "DUPLICATE"
' newcontact.Save
Debug.Print newcontact.Subject
End If
Set oldcontact = newcontact
End If
Next

End Sub