Delete all Identical mails in a folder. Compare the Subject and then the body data of the mail and delete all except 1.

Sub deleteExcessEmails()
Dim olkApp As Outlook.Application
Dim objns As Outlook.NameSpace
Dim olkmailitems As Outlook.items
Dim mailCounter As Integer
Dim bodyCount As Integer
Dim mai As Outlook.mailitem
Dim strFilter As String
    
    Set olkApp = Outlook.Application
    Set objns = olkApp.GetNamespace("MAPI")
    Set myfolder = olkApp.ActiveExplorer.CurrentFolder
    On Error GoTo skipthisone
    For mailCounter = myfolder.items.count To 1 Step -1
        Set mai = myfolder.items(mailCounter)
        strFilter = "[Subject] = " & append_quotes(mai.subject)
        Set olkmailitems = myfolder.items.Restrict(strFilter)
        For bodyCount = olkmailitems.count - 1 To 1 Step -1
            If mai.body = olkmailitems(bodyCount).body Then
                olkmailitems(bodyCount).Delete
            End If
        Next
skipthisone:
    Next
    
Set olkmailitems = Nothing
Set objns = Nothing
Set olkApp = Nothing
Set myfolder = Nothing
 
End Sub
 
Function append_quotes(objString As String) As String
    append_quotes = Chr(34) & CStr(objString) & Chr(34)
End Function
                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:

Sub deleteExcessEmails()
Dim olkApp As Outlook.Application
Dim objns As Outlook.NameSpace
Dim olkmailitems As Outlook.items
Dim mailCounter As Integer
Dim bodyCount As Integer
Dim mai As Object
Dim strFilter As String
    
    Set olkApp = Outlook.Application
    Set objns = olkApp.GetNamespace("MAPI")
    Set myfolder = olkApp.ActiveExplorer.CurrentFolder
    On Error GoTo skipthisone
    For mailCounter = myfolder.items.count To 1 Step -1
        Set mai = myfolder.items(mailCounter)
        If mai.Class = olMail Then
            strFilter = "[Subject] = " & append_quotes(mai.subject)
            Set olkmailitems = myfolder.items.Restrict(strFilter)
            For bodyCount = olkmailitems.count - 1 To 1 Step -1
                If mai.body = olkmailitems(bodyCount).body Then
                    olkmailitems(bodyCount).Delete
                End If
            Next
        End If
skipthisone:
    Next
    
Set olkmailitems = Nothing
Set objns = Nothing
Set olkApp = Nothing
Set myfolder = Nothing
 
End Sub
 
Function append_quotes(objString As String) As String
    append_quotes = Chr(34) & CStr(objString) & Chr(34)
End Function
                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:

Sub launchpad()
 
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim MyFolder As Outlook.MAPIFolder
    On Error Resume Next
   
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set MyFolder = objNS.PickFolder
    Call ProcessFolder(MyFolder)
    Set objNS = Nothing
 
Set MyFolder = Nothing
Set olApp = Nothing
Set objNS = Nothing
 
End Sub
 
Sub ProcessFolder(StartFolder As MAPIFolder)
Dim objFolder As Outlook.MAPIFolder
Dim mySubject As String
Dim dupSubject As String
Dim myItems As Items
Dim myInbox As MAPIFolder
Dim myItem As Object
Dim dupItem As Object
Dim myBody As String
Dim dupBody As String
   
    On Error Resume Next
   
  Set myItems = StartFolder.Items
   
  myItems.Sort "[Subject]", False
  Set myItem = myItems.GetFirst
  While TypeName(myItem) <> "Nothing"
    If TypeName(myItem) = "MailItem" Then
      mySubject = myItem.Subject
      myBody = myItem.Body
      If Err = 0 Then
        Set dupItem = myItems.GetNext
        If TypeName(dupItem) = "MailItem" Then
          dupSubject = dupItem.Subject
          dupBody = dupItem.Body
          If mySubject = dupSubject And myBody = dupBody Then
            dupItem.Delete
          Else
            Set myItem = dupItem
          End If
        Else
          dupItem = myItems.GetNext
        End If
      Else
        Err.Clear
        Set myItem = myItems.GetNext
      End If
    Else
      Set myItem = myItems.GetNext
    End If
  Wend
       
  ' process all the subfolders of this folder
  For Each objFolder In StartFolder.Folders
      Call ProcessFolder(objFolder)
  Next
 
Set myInbox = Nothing
Set myItem = Nothing
Set dupItem = Nothing
Set objFolder = Nothing
End Sub

                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:

Sub deleteExcessEmails()
Dim olkApp As Outlook.Application
Dim objns As Outlook.NameSpace
Dim olkmailitems As Outlook.items
Dim myfolder As Object
Dim mailCounter As Integer
Dim bodyCount As Integer
Dim mai As Object
Dim strFilter As String
Dim delItems As Object
Dim delItem As Variant
Dim intItems As Integer
    
    Set olkApp = Outlook.Application
    Set objns = olkApp.GetNamespace("MAPI")
    Set myfolder = olkApp.ActiveExplorer.CurrentFolder
    Set delItems = CreateObject("scripting.dictionary")
    On Error GoTo skipthisone
    For mailCounter = myfolder.items.count To 1 Step -1
        Set mai = myfolder.items(mailCounter)
        If mai.Class = olMail Then
            strFilter = "[Subject] = " & append_quotes(mai.subject)
            Set olkmailitems = myfolder.items.Restrict(strFilter)
            For bodyCount = olkmailitems.count - 1 To 1 Step -1
                If mai.body = olkmailitems(bodyCount).body Then
                    If Not delItems.Exists(olkmailitems(bodyCount).EntryID) Then
                        delItems.Add Key:=olkmailitems(bodyCount).EntryID, Item:=olkmailitems(bodyCount).EntryID
                        intItems = intItems + 1
                    End If
                End If
            Next
        End If
skipthisone:
    Next
    For Each delItem In delItems.Keys
        If delItems(delItem) <> "" Then _
            Application.Session.GetItemFromID(delItems(delItem)).Delete
    Next
    
Set olkmailitems = Nothing
Set objns = Nothing
Set olkApp = Nothing
Set myfolder = Nothing
 
End Sub
 
Function append_quotes(objString As String) As String
    append_quotes = Chr(34) & CStr(objString) & Chr(34)
End Function
                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:

Sub deleteExcessEmails()
Dim olkApp As Outlook.Application
Dim objns As Outlook.NameSpace
Dim olkmailitems As Outlook.items
Dim myfolder As Object
Dim mailCounter As Integer
Dim bodyCount As Integer
Dim mai As Object
Dim strFilter As String
Dim delItems As Object
Dim delItem As Variant
Dim intItems As Integer
    
    Set olkApp = Outlook.Application
    Set objns = olkApp.GetNamespace("MAPI")
    Set myfolder = olkApp.ActiveExplorer.CurrentFolder
    Set delItems = CreateObject("scripting.dictionary")
    On Error GoTo skipthisone
    Debug.Print "Items in folder at start is " & myfolder.items.count
    For mailCounter = myfolder.items.count To 1 Step -1
        Debug.Print "Processing mail item " & mailCounter & " of " & myfolder.items.count & " in the folder."
        Set mai = myfolder.items(mailCounter)
        If mai.Class = olMail Then
            strFilter = "[Subject] = " & append_quotes(mai.subject)
            Set olkmailitems = myfolder.items.Restrict(strFilter)
            For bodyCount = olkmailitems.count - 1 To 1 Step -1
                Debug.Print "Filtered items found is " & bodyCount
                If mai.body = olkmailitems(bodyCount).body Then
                    If Not delItems.Exists(olkmailitems(bodyCount).EntryID) Then
                        Debug.Print "New item entered into delitems list."
                        delItems.Add Key:=olkmailitems(bodyCount).EntryID, Item:=olkmailitems(bodyCount).EntryID
                        intItems = intItems + 1
                    End If
                End If
            Next
        End If
skipthisone:
    Next
    Debug.Print "Total items marked for deletion is " & delItems.count
    For Each delItem In delItems.Keys
        If delItems(delItem) <> "" Then
            Debug.Print "Deleting item " & delItems(delItem)
            Application.Session.GetItemFromID(delItems(delItem)).Delete
        End If
    Next
    
Set olkmailitems = Nothing
Set objns = Nothing
Set olkApp = Nothing
Set myfolder = Nothing
 
End Sub
 
Function append_quotes(objString As String) As String
    append_quotes = Chr(34) & CStr(objString) & Chr(34)
End Function
                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:

Sub deleteExcessEmails()
Dim olkApp As Outlook.Application
Dim objns As Outlook.NameSpace
Dim olkmailitems As Outlook.items
Dim myfolder As Object
Dim mailCounter As Integer
Dim bodyCount As Integer
Dim mai As Object
Dim strFilter As String
Dim delItems As Object
Dim delItem As Variant
Dim sortedList As Object
    
    Set olkApp = Outlook.Application
    Set objns = olkApp.GetNamespace("MAPI")
    Set myfolder = olkApp.ActiveExplorer.CurrentFolder
    Set delItems = CreateObject("scripting.dictionary")
    On Error GoTo skipthisone
    Debug.Print "Items in folder at start is " & myfolder.items.count
    Set sortedList = myfolder.items
    sortedList.Sort "[Subject]", olAscending
    mailCounter = sortedList.count
    Do While mailCounter > 1
'    For mailCounter = myfolder.items.count To 1 Step -1
        Debug.Print "Processing mail item " & mailCounter & " of " & myfolder.items.count & " in the folder."
        Set mai = myfolder.items(mailCounter)
        If mai.Class = olMail Then
            strFilter = "[Subject] = " & append_quotes(mai.subject)
            Set olkmailitems = sortedList.Restrict(strFilter)
            For bodyCount = olkmailitems.count - 1 To 1 Step -1
                Debug.Print "Filtered items found is " & bodyCount
                If mai.body = olkmailitems(bodyCount).body Then
                    If Not delItems.Exists(olkmailitems(bodyCount).EntryID) Then
                        Debug.Print "New item entered into delitems list."
                        delItems.Add Key:=olkmailitems(bodyCount).EntryID, Item:=olkmailitems(bodyCount).EntryID
                        mailCounter = mailCounter - 1
                    End If
                End If
            Next
        End If
        mailCounter = mailCounter - 1
skipthisone:
    Loop
    Debug.Print "Total items marked for deletion is " & delItems.count
    For Each delItem In delItems.Keys
        If delItems(delItem) <> "" Then
            Debug.Print "Deleting item " & delItems(delItem)
            Application.Session.GetItemFromID(delItems(delItem)).Delete
        End If
    Next
    
Set olkmailitems = Nothing
Set objns = Nothing
Set olkApp = Nothing
Set myfolder = Nothing
 
End Sub
 
Function append_quotes(objString As String) As String
    append_quotes = Chr(34) & CStr(objString) & Chr(34)
End Function
                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:

Sub deleteExcessEmails()
Dim olkApp As Outlook.Application
Dim objns As Outlook.NameSpace
Dim olkmailitems As Outlook.items
Dim myfolder As Object
Dim mailCounter As Integer
Dim bodyCount As Integer
Dim mai As Object
Dim strFilter As String
Dim delItems As Object
Dim delItem As Variant
Dim sortedList As Object
    
    Set olkApp = Outlook.Application
    Set objns = olkApp.GetNamespace("MAPI")
    Set myfolder = olkApp.ActiveExplorer.CurrentFolder
    Set delItems = CreateObject("scripting.dictionary")
    On Error GoTo skipthisone
    Debug.Print "Items in folder at start is " & myfolder.items.count
    Set sortedList = myfolder.items
    sortedList.Sort "[Subject]", olAscending
    mailCounter = sortedList.count
    Do While mailCounter > 0
'    For mailCounter = myfolder.items.count To 1 Step -1
        Debug.Print "Processing mail item " & mailCounter & " of " & myfolder.items.count & " in the folder."
        Set mai = myfolder.items(mailCounter)
        If mai.Class = olMail Then
            strFilter = "[Subject] = " & append_quotes(mai.subject)
            Set olkmailitems = sortedList.Restrict(strFilter)
            For bodyCount = olkmailitems.count - 1 To 1 Step -1
                Debug.Print "Filtered items found is " & bodyCount
                If mai.body = olkmailitems(bodyCount).body Then
                    If Not delItems.Exists(olkmailitems(bodyCount).EntryID) Then
                        Debug.Print "New item entered into delitems list."
                        delItems.Add Key:=olkmailitems(bodyCount).EntryID, Item:=olkmailitems(bodyCount).EntryID
                        mailCounter = mailCounter - 1
                    End If
                End If
            Next
        End If
        mailCounter = mailCounter - 1
skipthisone:
    Loop
    Debug.Print "Total items marked for deletion is " & delItems.count
    For Each delItem In delItems.Keys
        If delItems(delItem) <> "" Then
            Debug.Print "Deleting item " & delItems(delItem)
            Application.Session.GetItemFromID(delItems(delItem)).Delete
        End If
    Next
    
Set olkmailitems = Nothing
Set objns = Nothing
Set olkApp = Nothing
Set myfolder = Nothing
 
End Sub
 
Function append_quotes(objString As String) As String
    append_quotes = Chr(34) & CStr(objString) & Chr(34)
End Function
                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:

Sub deleteExcessEmails()
Dim olkApp As Outlook.Application
Dim objns As Outlook.NameSpace
Dim olkmailitems As Outlook.items
Dim myfolder As Object
Dim mailCounter As Integer
Dim bodyCount As Integer
Dim mai As Object
Dim strFilter As String
Dim delItems As Object
Dim delItem As Variant
Dim sortedList As Object
    
    Set olkApp = Outlook.Application
    Set objns = olkApp.GetNamespace("MAPI")
    Set myfolder = olkApp.ActiveExplorer.CurrentFolder
    Set delItems = CreateObject("scripting.dictionary")
    On Error GoTo skipthisone
'    Debug.Print "Items in folder at start is " & myfolder.items.count
    Set sortedList = myfolder.items
    sortedList.Sort "[Subject]", olAscending
    mailCounter = sortedList.count
    Do While mailCounter > 0
'    For mailCounter = myfolder.items.count To 1 Step -1
'        Debug.Print "Processing mail item " & mailCounter & " of " & myfolder.items.count & " in the folder."
        Set mai = myfolder.items(mailCounter)
        If mai.Class = olMail Then
            strFilter = "[Subject] = " & append_quotes(mai.subject)
            Set olkmailitems = sortedList.Restrict(strFilter)
            For bodyCount = olkmailitems.count - 1 To 1 Step -1
'                Debug.Print "Filtered items found is " & bodyCount
                If mai.body = olkmailitems(bodyCount).body Then
                    If Not delItems.Exists(olkmailitems(bodyCount).EntryID) Then
'                        Debug.Print "New item entered into delitems list."
                        delItems.Add Key:=olkmailitems(bodyCount).EntryID, Item:=olkmailitems(bodyCount).EntryID
                        olkmailitems(bodyCount).Delete
                        mailCounter = mailCounter - 1
                    End If
                End If
            Next
        End If
        mailCounter = mailCounter - 1
skipthisone:
    Loop
'    Debug.Print "Total items marked for deletion is " & delItems.count
'    For Each delItem In delItems.Keys
'        If delItems(delItem) <> "" Then
'            Debug.Print "Deleting item " & delItems(delItem)
'            Application.Session.GetItemFromID(delItems(delItem)).Delete
'        End If
'    Next
    
Set olkmailitems = Nothing
Set objns = Nothing
Set olkApp = Nothing
Set myfolder = Nothing
 
End Sub
 
Function append_quotes(objString As String) As String
    append_quotes = Chr(34) & CStr(objString) & Chr(34)
End Function

                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:

Sub deleteExcessEmails()
Dim olkApp As Outlook.Application
Dim objns As Outlook.NameSpace
Dim olkmailitems As Outlook.items
Dim myfolder As Object
Dim mailCounter As Integer
Dim bodyCount As Integer
Dim mai As Object
Dim strFilter As String
Dim delItems As Object
Dim delItem As Variant
Dim sortedList As Object
    
    Set olkApp = Outlook.Application
    Set objns = olkApp.GetNamespace("MAPI")
    Set myfolder = olkApp.ActiveExplorer.CurrentFolder
    Set delItems = CreateObject("scripting.dictionary")
    On Error GoTo skipthisone
'    Debug.Print "Items in folder at start is " & myfolder.items.count
    Set sortedList = myfolder.items
    sortedList.Sort "[Subject]", olAscending
    mailCounter = sortedList.count
    Do While mailCounter > 0
'    For mailCounter = myfolder.items.count To 1 Step -1
'        Debug.Print "Processing mail item " & mailCounter & " of " & myfolder.items.count & " in the folder."
        Set mai = myfolder.items(mailCounter)
        If mai.Class = olMail Then
            strFilter = "[Subject] = " & append_quotes(mai.subject)
            Set olkmailitems = sortedList.Restrict(strFilter)
            For bodyCount = olkmailitems.count - 1 To 1 Step -1
                If delItems.count <> 0 Then delItems.RemoveAll
'                Debug.Print "Filtered items found is " & bodyCount
                If mai.body = olkmailitems(bodyCount).body Then
                    If Not delItems.Exists(olkmailitems(bodyCount).EntryID) Then
'                        Debug.Print "New item entered into delitems list."
                        delItems.Add Key:=olkmailitems(bodyCount).EntryID, Item:=olkmailitems(bodyCount).EntryID
                        olkmailitems(bodyCount).Delete
                        mailCounter = mailCounter - 1
                    End If
                End If
            Next
        End If
        mailCounter = mailCounter - 1
skipthisone:
    Loop
'    Debug.Print "Total items marked for deletion is " & delItems.count
'    For Each delItem In delItems.Keys
'        If delItems(delItem) <> "" Then
'            Debug.Print "Deleting item " & delItems(delItem)
'            Application.Session.GetItemFromID(delItems(delItem)).Delete
'        End If
'    Next
    
Set olkmailitems = Nothing
Set objns = Nothing
Set olkApp = Nothing
Set myfolder = Nothing
 
End Sub
 
Function append_quotes(objString As String) As String
    append_quotes = Chr(34) & CStr(objString) & Chr(34)
End Function

                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:

Sub deleteExcessEmails()
Dim olkApp As Outlook.Application
Dim objns As Outlook.NameSpace
Dim olkmailitems As Outlook.items
Dim myfolder As Object
Dim mailCounter As Integer
Dim bodyCount As Integer
Dim mai As Object
Dim strFilter As String
Dim delItems As Object
Dim delItem As Variant
Dim sortedList As Object
    
    Set olkApp = Outlook.Application
    Set objns = olkApp.GetNamespace("MAPI")
    Set myfolder = olkApp.ActiveExplorer.CurrentFolder
    Set delItems = CreateObject("scripting.dictionary")
    On Error GoTo skipthisone
'    Debug.Print "Items in folder at start is " & myfolder.items.count
    Set sortedList = myfolder.items
    sortedList.Sort "[Subject]", olAscending
    mailCounter = sortedList.count
    Do While mailCounter > 0
'    For mailCounter = myfolder.items.count To 1 Step -1
'        Debug.Print "Processing mail item " & mailCounter & " of " & myfolder.items.count & " in the folder."
        Set mai = myfolder.items(mailCounter)
        If mai.Class = olMail Then
            strFilter = "[Subject] = " & append_quotes(mai.subject)
            Set olkmailitems = sortedList.Restrict(strFilter)
            Set mai = olkmailitems.items(mailCounter)
            For bodyCount = olkmailitems.count - 1 To 1 Step -1
                If delItems.count <> 0 Then delItems.RemoveAll
'                Debug.Print "Filtered items found is " & bodyCount
                If mai.body = olkmailitems(bodyCount).body Then
                    If Not delItems.Exists(olkmailitems(bodyCount).EntryID) Then
'                        Debug.Print "New item entered into delitems list."
                        delItems.Add Key:=olkmailitems(bodyCount).EntryID, Item:=olkmailitems(bodyCount).EntryID
                        olkmailitems(bodyCount).Delete
                        mailCounter = mailCounter - 1
                    End If
                End If
            Next
        End If
        mailCounter = mailCounter - 1
skipthisone:
    Loop
'    Debug.Print "Total items marked for deletion is " & delItems.count
'    For Each delItem In delItems.Keys
'        If delItems(delItem) <> "" Then
'            Debug.Print "Deleting item " & delItems(delItem)
'            Application.Session.GetItemFromID(delItems(delItem)).Delete
'        End If
'    Next
    
Set olkmailitems = Nothing
Set objns = Nothing
Set olkApp = Nothing
Set myfolder = Nothing
 
End Sub
 
Function append_quotes(objString As String) As String
    append_quotes = Chr(34) & CStr(objString) & Chr(34)
End Function
                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:

Sub deleteExcessEmails()
Dim olkApp As Outlook.Application
Dim objns As Outlook.NameSpace
Dim olkmailitems As Outlook.items
Dim myfolder As Object
Dim mailCounter As Integer
Dim bodyCount As Integer
Dim mai As Object
Dim strFilter As String
Dim delItems As Object
Dim delItem As Variant
Dim sortedList As Object
    
    Set olkApp = Outlook.Application
    Set objns = olkApp.GetNamespace("MAPI")
    Set myfolder = olkApp.ActiveExplorer.CurrentFolder
    Set delItems = CreateObject("scripting.dictionary")
    On Error GoTo skipthisone
'    Debug.Print "Items in folder at start is " & myfolder.items.count
    Set sortedList = myfolder.items
    sortedList.Sort "[Subject]", olAscending
    mailCounter = sortedList.count
    Do While mailCounter > 0
'    For mailCounter = myfolder.items.count To 1 Step -1
'        Debug.Print "Processing mail item " & mailCounter & " of " & myfolder.items.count & " in the folder."
        Set mai = myfolder.items(mailCounter)
        If mai.Class = olMail Then
            strFilter = "[Subject] = " & append_quotes(mai.subject)
            Set olkmailitems = sortedList.Restrict(strFilter)
            Set mai = olkmailitems(olkmailitems.count)
            For bodyCount = olkmailitems.count - 1 To 1 Step -1
                If delItems.count <> 0 Then delItems.RemoveAll
'                Debug.Print "Filtered items found is " & bodyCount
                If mai.body = olkmailitems(bodyCount).body Then
                    If Not delItems.Exists(olkmailitems(bodyCount).EntryID) Then
'                        Debug.Print "New item entered into delitems list."
                        delItems.Add Key:=olkmailitems(bodyCount).EntryID, Item:=olkmailitems(bodyCount).EntryID
                        olkmailitems(bodyCount).Delete
                        mailCounter = mailCounter - 1
                    End If
                End If
            Next
        End If
        mailCounter = mailCounter - 1
skipthisone:
    Loop
'    Debug.Print "Total items marked for deletion is " & delItems.count
'    For Each delItem In delItems.Keys
'        If delItems(delItem) <> "" Then
'            Debug.Print "Deleting item " & delItems(delItem)
'            Application.Session.GetItemFromID(delItems(delItem)).Delete
'        End If
'    Next
    
Set olkmailitems = Nothing
Set objns = Nothing
Set olkApp = Nothing
Set myfolder = Nothing
 
End Sub
 
Function append_quotes(objString As String) As String
    append_quotes = Chr(34) & CStr(objString) & Chr(34)
End Function

                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64: