从文件夹中删除重复的Outlook项目

问题

当我将项目从在线存档移动到pst文件时,Outlook 2016已损坏.

PST文件已被恢复....但许多项目(~7000)重复5次

有一系列项目类型,标准消息,会议请求等

我尝试了什么,我
看了现有的解决方案和工具,包括:

重复删除工具 - 除了一次删除10个项目的试用选项之外,其中没有一个是免费的.

各种代码解决方案包括:
Jacob Hilderbrand 在Outlook中从Excel 宏运行
以删除重复电子邮件的努力 -

我决定采用代码路由,因为它相对简单,并且可以更好地控制重复报告的方式.

我将在下面发布自己的解决方案,因为它可能会帮助其他人

我希望看到其他可能的方法(也许是PowerShell)来解决这个问题,这可能比我的更好.

方法如下:

为用户提供选择要处理的文件夹的提示

在Subject,Sender,CreationTime和Size的基础上检查重复项

将任何重复项移动(而不是删除)到正在处理的文件夹的子文件夹(已删除项目)中.

创建一个CSV文件 - 存储在路径下,StrPath以创建已移动电子邮件的Outlook外部参考.

更新:检查大小令人惊讶地错过了一些欺骗,即使是其他相同的邮件.我已将测试更改为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