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

Question

问题

1. 当我将在线存档中的项目移动到pst文件时，Outlook 2016已损坏。
2. PST文件已被恢复....但许多项目（~7000）重复5次
3. 有一系列项目类型，标准消息，会议请求等

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

1. duplicate removal tools - 除了一次删除10件商品的试用选项外，其中任何一件都是免费的。
2. 各种代码解决方案包括：
   从Excel运行的Jacob Hilderbrand's effort Macro in Outlook to delete duplicate emails-

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

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

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

Answer 1

以下方法：

1. 为用户提供选择要处理的文件夹的提示
2. 在主题，发件人， CreationTime 和尺寸
的基础上检查重复项
3. 将所有重复项移动（而不是删除）到正在处理的文件夹的子文件夹（已删除项目）。
4. 创建一个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

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

亲爱的，谢谢你非常，你救了我的一天：-) 我简化了重复搜索，因为我从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

Answer 4

我已经编写了一个名为“ Outlook Duplicated Items Remover”的VBA脚本

源代码为available on GitHub

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