Remove duplicate Outlook items from a folder

Question

issue

1. Outlook 2016 corrupted while I was moving items from an online archive into a pst file.
2. The PST file has been recovered .... but many items (~7000) are duplicated 5 times
3. There are a range of item types, standard messages, meeting requests etc

what I tried
I looked at existing solutions and tools, including:

1. duplicate removal tools - none of which were free other than a trial option to remove 10 items at a time.
2. A variety of code solutions including:
   Jacob Hilderbrand's effort which runs from Excel
   Macro in Outlook to delete duplicate emails-

I decided to go the code route as it was relatively simple and to gain more control over how the duplicates were reported.

I will post my self solution below as it may help others.

I would like to see other potential approaches (perhaps powershell) to fixing this problem which may be better than mine.

Answer 1

The approach below:

1. Provides users with a prompt to select the folder to process
2. Checks duplicates on the base of Subject, Sender, CreationTime and Size
3. Moved (rather than delete) any duplicates into a sub-folder (removed items) of the folder being processed.
4. Create a CSV file - stored under the path in StrPath to create a external reference to Outlook of the emails that have been moved.

Updated: Checking for size surprisingly missed a number of dupes, even for otherwise identical mail items. I have changed the test to subject and body

Tested on Outlook 2016

Const strPath = "c:\temp\deleted msg.csv"
Sub DeleteDuplicateEmails()

Dim lngCnt As Long
Dim objMail As Object
Dim objFSO As Object
Dim objTF As Object

Dim objDic As Object
Dim objItem As Object
Dim olApp As Outlook.Application
Dim olNS As NameSpace
Dim olFolder As Folder
Dim olFolder2 As Folder
Dim strCheck As String

Set objDic = CreateObject("scripting.dictionary")
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.CreateTextFile(strPath)
objTF.WriteLine "Subject"

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.PickFolder

If olFolder Is Nothing Then Exit Sub

On Error Resume Next
Set olFolder2 = olFolder.Folders("removed items")
On Error GoTo 0

If olFolder2 Is Nothing Then Set olFolder2 = olFolder.Folders.Add("removed items")


For lngCnt = olFolder.Items.Count To 1 Step -1

Set objItem = olFolder.Items(lngCnt)

strCheck = objItem.Subject & "," & objItem.Body & ","
strCheck = Replace(strCheck, ", ", Chr(32))

    If objDic.Exists(strCheck) Then
       objItem.Move olFolder2
       objTF.WriteLine Replace(objItem.Subject, ", ", Chr(32))
    Else
        objDic.Add strCheck, True
    End If
Next

If objTF.Line > 2 Then
    MsgBox "duplicate items were removed to ""removed items""", vbCritical, "See " & strPath & " for details"
Else
    MsgBox "No duplicates found"
End If
End Sub