R
R Avery
Outlook XP
I have an email folder that has lots of duplicate emails because of
someone who always re-copied an email to the folder when he couldn't
immediately find it (so that the folder would always have at least one
copy of everything), but I need to now rid it of the duplicate emails.
I have written the function below to accomplish the task, but it is so
incredibly slow. I will try to make a smarter algorithm, but even on a
test folder of only 200 mailitems, it takes more than 5 minutes to get
through just half.
Does anyone have a faster solution, or is there some built-in way to
eradicate duplicates? The code I have used is below. Any help would be
most appreciated.
Public Sub DeleteDuplicateEmails()
Dim i As Long, j As Long
Dim mi As MailItem, mi2 As MailItem
Dim fol As MAPIFolder
Set fol = ActiveExplorer.CurrentFolder
With fol.Items
For i = .Count To 1 Step -1
Debug.Print "Looking at mailitem " & i & " of " & .Count
For j = .Count To i + 1 Step -1
Set mi = .Item(i)
Set mi2 = .Item(j)
If IsDuplicateEmail(mi, mi2) Then
mi2.Delete
End If
Next
Next
End With
End Sub
Public Function IsDuplicateEmail(mi As MailItem, mi2 As MailItem) As Boolean
Dim bln As Boolean
bln = (mi2.Subject = mi.Subject) And _
(Abs(mi2.SentOn - mi.SentOn) < 0.00001) And _
(Abs(mi2.ReceivedTime - mi.ReceivedTime) < 0.00001) And _
mi2.CC = mi.CC And _
mi2.SenderName = mi.SenderName
IsDuplicateEmail = bln
End Function
I have an email folder that has lots of duplicate emails because of
someone who always re-copied an email to the folder when he couldn't
immediately find it (so that the folder would always have at least one
copy of everything), but I need to now rid it of the duplicate emails.
I have written the function below to accomplish the task, but it is so
incredibly slow. I will try to make a smarter algorithm, but even on a
test folder of only 200 mailitems, it takes more than 5 minutes to get
through just half.
Does anyone have a faster solution, or is there some built-in way to
eradicate duplicates? The code I have used is below. Any help would be
most appreciated.
Public Sub DeleteDuplicateEmails()
Dim i As Long, j As Long
Dim mi As MailItem, mi2 As MailItem
Dim fol As MAPIFolder
Set fol = ActiveExplorer.CurrentFolder
With fol.Items
For i = .Count To 1 Step -1
Debug.Print "Looking at mailitem " & i & " of " & .Count
For j = .Count To i + 1 Step -1
Set mi = .Item(i)
Set mi2 = .Item(j)
If IsDuplicateEmail(mi, mi2) Then
mi2.Delete
End If
Next
Next
End With
End Sub
Public Function IsDuplicateEmail(mi As MailItem, mi2 As MailItem) As Boolean
Dim bln As Boolean
bln = (mi2.Subject = mi.Subject) And _
(Abs(mi2.SentOn - mi.SentOn) < 0.00001) And _
(Abs(mi2.ReceivedTime - mi.ReceivedTime) < 0.00001) And _
mi2.CC = mi.CC And _
mi2.SenderName = mi.SenderName
IsDuplicateEmail = bln
End Function