问题
我尝试了什么
我查看了现有的解决方案和工具，包括：
我决定采用代码路线，因为它相对简单，并且可以更好地控制重复报告的方式。
我将在下面发布我的自我解决方案，因为它可能对其他人有所帮助。
我希望看到其他可能的方法（也许是 powershell）来解决这个问题，这可能比我的更好。
下面的方法：
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
这是一个利用排序电子邮件来更有效地检查重复项的脚本。
如果您以确定的顺序（例如接收日期）处理电子邮件，则无需维护您所看到的每封电子邮件的巨大字典。一旦日期更改，您就知道您将永远不会再看到包含先前日期的另一封电子邮件，因此它们不会重复，因此您可以在每次更改日期时清除您的字典。
该脚本还考虑到一些项目使用 HTMLBody 来定义完整的消息，而其他项目没有该属性。
Sub DeleteDuplicateEmails()
Dim allMails As Outlook.Items
Dim objMail As Object, objDic As Object, objLastMail As Object
Dim olFolder As Folder, olDuplicatesFolder As Folder
Dim strCheck As String
Dim received As Date, lastReceived As Date
Set objDic = CreateObject("scripting.dictionary")
With Outlook.Application.GetNamespace("MAPI")
Set olFolder = .PickFolder
End With
If olFolder Is Nothing Then Exit Sub
On Error Resume Next
Set olDuplicatesFolder = olFolder.Folders("Duplicates")
On Error GoTo 0
If olDuplicatesFolder Is Nothing Then Set olDuplicatesFolder = olFolder.Folders.Add("Duplicates")
Debug.Print "Sorting " & olFolder.Name & " by ReceivedTime..."
Set allMails = olFolder.Items
allMails.Sort "[ReceivedTime]", True
Dim totalCount As Long, index As Long
totalCount = allMails.count
Debug.Print totalCount & " Items to Process..."
lastReceived = "1/1/1987"
For index = totalCount - 1 To 1 Step -1
Set objMail = allMails(index)
received = objMail.ReceivedTime
If received < lastReceived Then
Debug.Print "Error: Expected emails to be in order of date recieved. Previous mail was " & lastReceived _
& " current is " & received
Exit Sub
ElseIf received = lastReceived Then
' Might be a duplicate track mail contents until this recieved time changes.
' Add the last mail to the dictionary if it hasn't been tracked yet
If Not objLastMail Is Nothing Then
Debug.Print "Found multiple emais recieved at " & lastReceived & ", checking for duplicates..."
objDic.Add GetMailKey(objLastMail), True
End If
' Now check the current mail item to see if it's a duplicate
strCheck = GetMailKey(objMail)
If objDic.Exists(strCheck) Then
Debug.Print "Found Duplicate: """ & objMail.Subject & " on " & lastReceived
objMail.Move olDuplicatesFolder
DoEvents
Else
objDic.Add strCheck, True
End If
' No need to track the last mail, since we have it in the dictionary
Set objLastMail = Nothing
Else
' This can't be a duplicate, it has a different date, reset our dictionary
objDic.RemoveAll
lastReceived = received
' Keep track of this mail in case we end up needing to build a dictionary
Set objLastMail = objMail
End If
' Progress update
If index Mod 10 = 0 Then
Debug.Print index & " Remaining..."
End If
DoEvents
Next
Debug.Print "Finished moving Duplicate Emails"
End Sub
以及上面提到的用于“唯一识别”电子邮件的辅助函数。根据需要进行调整，但我认为如果主题和全身相同，则检查其他任何内容都没有意义。也适用于日历邀请等：
Function GetMailKey(ByRef objMail As Object) As String
On Error GoTo NoHTML
GetMailKey = objMail.Subject & objMail.HTMLBody
Exit Function
BodyKey:
On Error GoTo 0
GetMailKey = objMail.Subject & objMail.Body
Exit Function
NoHTML:
Err.Clear
Resume BodyKey
End Function
我简化了重复搜索，因为在我的情况下，我从 PST 文件中导入了多个重复项，但完整的邮件正文不匹配。我不知道为什么，因为我确信这些邮件是真正的重复邮件。
我的简化是只匹配接收时间戳和主题。
我为函数中遇到的错误添加了一个错误异常：Set olDuplicatesFolder = olFolder.Folders("Duplicates")。
我为 debug.print 消息做了不同的格式。
Attribute VB_Name = "DelDupEmails_DATE_SUBJECT"
Sub DeleteDuplicateEmails_DATE_SUBJECT()
Dim allMails As Outlook.Items
Dim objMail As Object, objDic As Object, objLastMail As Object
Dim olFolder As Folder, olDuplicatesFolder As Folder
Dim strCheck As String
Dim received As Date, lastReceived As Date
Set objDic = CreateObject("scripting.dictionary")
With Outlook.Application.GetNamespace("MAPI")
Set olFolder = .PickFolder
End With
If olFolder Is Nothing Then Exit Sub
On Error Resume Next
Set olDuplicatesFolder = olFolder.Folders("Duplicates")
On Error GoTo 0
If olDuplicatesFolder Is Nothing Then Set olDuplicatesFolder = olFolder.Folders.Add("Duplicates")
Debug.Print "Sorting " & olFolder.Name & " by ReceivedTime..."
Set allMails = olFolder.Items
allMails.Sort "[ReceivedTime]", True
Dim totalCount As Long, index As Long
totalCount = allMails.Count
Debug.Print totalCount & " Items to Process..."
'MsgBox totalCount & " Items to Process..."
lastReceived = "1/1/1987"
For index = totalCount - 1 To 1 Step -1
Set objMail = allMails(index)
On Error Resume Next
received = objMail.ReceivedTime
On Error GoTo 0
If received < lastReceived Then
Debug.Print "Error: Expected emails to be in order of date recieved. Previous mail was " & lastReceived _
& " current is " & received
Exit Sub
ElseIf received = lastReceived Then
' Might be a duplicate track mail contents until this recieved time changes.
' Add the last mail to the dictionary if it hasn't been tracked yet
If Not objLastMail Is Nothing Then
Debug.Print olFolder & " : Found multiple emails recieved at " & lastReceived & ", checking for duplicates..."
'MsgBox "Found multiple emails recieved at " & lastReceived & ", checking for duplicates..."
objDic.Add GetMailKey(objLastMail), True
End If
' Now check the current mail item to see if it's a duplicate
strCheck = GetMailKey(objMail)
If objDic.Exists(strCheck) Then
Debug.Print "#" & index & " - Duplicate: " & lastReceived & " " & objMail.Subject
'Debug.Print "Found Duplicate: """ & objMail.Subject & " on " & lastReceived
'MsgBox "Found Duplicate: """ & objMail.Subject & " on " & lastReceived
objMail.Move olDuplicatesFolder
DoEvents
Else
objDic.Add strCheck, True
End If
' No need to track the last mail, since we have it in the dictionary
Set objLastMail = Nothing
Else
' This can't be a duplicate, it has a different date, reset our dictionary
objDic.RemoveAll
lastReceived = received
' Keep track of this mail in case we end up needing to build a dictionary
Set objLastMail = objMail
End If
' Progress update
If index Mod 100 = 0 Then
Debug.Print index & " Remaining... from " & olFolder
'MsgBox index & " Remaining..."
End If
DoEvents
Next
Debug.Print "Finished moving Duplicate Emails"
MsgBox "Finished moving Duplicate Emails"
End Sub
Function GetMailKey(ByRef objMail As Object) As String
On Error GoTo NoHTML
'GetMailKey = objMail.Subject & objMail.HTMLBody
GetMailKey = objMail.Subject ' & objMail.HTMLBody
Exit Function
BodyKey:
On Error GoTo 0
'GetMailKey = objMail.Subject & objMail.Body
GetMailKey = objMail.Subject ' & objMail.Body
Exit Function
NoHTML:
Err.Clear
Resume BodyKey
End Function
我编写了一个名为“Outlook Duplicated Items Remover”的 VBA 脚本
源代码在 GitHub 上可用
它将在文件夹及其子文件夹中找到所有重复的项目并将它们移动到专用文件夹