Removing duplicate Outlook items from a folder

Question

issue

• Outlook 2016 is corrupted when I moved items from the online archive to a pst file.
• The PST file was restored .... but many items (~ 7000) are duplicated 5 times
• There are a number of item types, standard messages, meeting requests, etc.

what I tried I reviewed existing solutions and tools, including:

• duplicate removal tools - none of them was free, except for trial, to remove 10 items at a time.
• Various software solutions, including:
  Jacob Hilderbrand , which runs from Excel
  Macro Outlook to remove duplicate emails -

I decided to follow the code as it was relatively simple and to get more control over how duplicates were reported.

I will post my own solution below, as this may help others.

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

Answer 1

Approach below:

• Invites users to select a folder to process
• Checks for duplicates based on Subject, Sender, CreationTime and Size
• Moved (and not deleted) any duplicates to the subfolder (deleted items) of the processed folder.
• Create a CSV file - save it along the path to StrPathto create an external link to Outlook moved emails.

: , . subject body

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