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

Question

问题

1. Outlook 2016在我将项目从联机存档移动到pst文件时损坏
2. PST文件已恢复。。。。但许多项目（约7000个）重复了5次
3. 有一系列项目类型、标准消息、会议请求等

我尝试了什么
我查看了现有的解决方案和工具，包括：

1. 重复删除工具-除了一次删除10个项目的试用选项外，没有一个是免费的
2. 各种代码解决方案，包括：
   Jacob Hilderbrand从Excel运行的努力
   Outlook中用于删除重复电子邮件的宏-

我决定走代码路线，因为它相对简单，并对重复项的报告方式有更多的控制权。

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

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

Answer 1

下面的方法：

1. 为用户提供选择要处理的文件夹的提示
2. 根据主题、发件人，创作时间和大小检查重复项
3. 将任何重复项移动（而不是删除）到正在处理的文件夹的子文件夹中（已删除项）
4. 创建一个CSV文件-存储在StrPath中的路径下，以创建已移动电子邮件的Outlook外部引用

更新：检查大小令人惊讶地错过了许多重复，即使是在其他方面相同的邮件项目。我已将测试更改为subject和body

在Outlook 2016上测试

Const strPath = "c:tempdeleted 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

Answer 2

这里有一个脚本，它利用对电子邮件进行排序的优势，更有效地检查重复邮件。

如果你按照确定的顺序（例如收到日期）处理电子邮件，就没有必要为你看到的每封电子邮件都维护一个庞大的词典。一旦日期更改，你就知道你再也看不到以前日期的电子邮件了，因此，它们不会重复，所以你可以在每次日期更改时清除词典。

这个脚本还考虑到这样一个事实，即一些项目使用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

Answer 3

我写了一个VBA脚本，名为"Outlook重复项目删除程序"；

源代码可在GitHub 上获得

它将在文件夹及其子文件夹中找到所有重复的项目，并将它们移动到专用文件夹

Answer 4

我简化了重复搜索，因为在我的案例中，我从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