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

Question

问题

当我将项目从在线存档移动到 pst 文件时，Outlook 2016 损坏了。

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

有一系列项目类型、标准消息、 session 请求等

我试过的
我查看了现有的解决方案和工具，包括:

duplicate removal tools - 除了一次删除 10 个项目的试用选项之外，没有一个是免费的。

多种代码解决方案，包括:
Jacob Hilderbrand's effort从 Excel 运行
Macro in Outlook to delete duplicate emails-

我决定走代码路线，因为它相对简单，并且可以更好地控制重复报告的方式。

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

我希望看到其他可能的方法(可能是 powershell)来解决这个问题，这些方法可能比我的更好。

Answer 1

下面的方法:

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

根据主题、发件人、创建时间和大小检查重复项

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

创建一个 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