I would make a new folder. Export the old folders. Import them into new
folder and I use this macro to remove dup emails. Hope it helps.
It's slow; so expect it to take a while. It only works on one folder; but a
little mod to it could make it do all folders. If someone has found a faster
way, let me know. I couldn't get the folder to sort so I had to look at each
mail item in the folder. The sort routine worked at app level; but when I
looked at it from in the macro, none were sorted.
Sub FindDups() 'look for emails
Dim omail As Outlook.MailItem, tmail As Outlook.MailItem
Dim intDashLoc As Integer
Dim intPeriodLoc As Integer
Dim flgException As Boolean
Dim intThisFolderItem As Integer, intTempFolderItem As Integer
Dim intSubCount As Integer
Dim intGameTurn As Integer, intCount As Integer
Dim intDay As Integer
Dim strSubject As String, strtSubject As String
Dim strTime As String, strtTime As String
Dim First As Boolean
Dim Deleted As Integer
Const intMaxMoves = 2 'power of ten 10^2
Dim dateTemp As Date, dateEmail As Date
Dim ThisFolder As Outlook.MAPIFolder
strLast = ""
strLastTime = ""
' Set ThisFolder = FindFolder("__Rotary")
Set ThisFolder = GetFolder
For intThisFolderItem = ThisFolder.Items.Count To 1 Step -1
On Error GoTo DoNextI 'Errors on folders
flgSave = False
If intThisFolderItem = 0 Then GoTo DoNextI
On Error GoTo DoNextI
If ThisFolder.Items(intThisFolderItem).Class = 46 Then
Debug.Print ThisFolder.Items(intThisFolderItem)
GoTo DoNextI
End If
Set omail = ThisFolder.Items(intThisFolderItem)
On Error GoTo 0
strSubject = omail.Subject
strTime = omail.ReceivedTime
First = True
Deleted = 0
For intTempFolderItem = intThisFolderItem To 1 Step -1
On Error GoTo DoNextTemp
If ThisFolder.Items(intTempFolderItem).Class = 46 Then
GoTo DoNextTemp
End If
Set tmail = ThisFolder.Items(intTempFolderItem)
On Error GoTo 0
strtSubject = tmail.Subject
strtTime = tmail.ReceivedTime
If strSubject = strtSubject And strTime = strtTime Then
'Duplicate of last one
Debug.Print
If Not First Then
Debug.Print tmail.Subject; " "; tmail.ReceivedTime;
" Deleted"; intTempFolderItem
tmail.Delete
Deleted = Deleted + 1
Else
Debug.Print tmail.Subject; " "; tmail.ReceivedTime;
" First:"; intTempFolderItem
First = False
End If
Else
End If
DoNextTemp:
Next intTempFolderItem
' If flgSave Then
' omail.Subject = strSubject
' omail.Save
' End If
DoNextI: 'Graceful Error exit point
intThisFolderItem = intThisFolderItem - Deleted
' Debug.Print
Next intThisFolderItem
Set omail = Nothing 'destroy instance
Set tmail = Nothing
End Sub
Function GetFolder() As Outlook.MAPIFolder
Dim omail As Outlook.MailItem, tmail As Outlook.MailItem
Dim ThisFolder As Outlook.MAPIFolder
Dim FolderName As String
Set GetFolder = Application.Explorers.Item(1).CurrentFolder
Debug.Print GetFolder.Name
End Function
