删除重复邮件 Outlook 2013

Question

我正在尝试创建一个 VBA 宏来检查是否有重复的邮件（查看主题）然后删除邮件。

此代码有效，但正在删除最旧的重复项。它按降序计数，我似乎无法对项目进行排序。

基本上，我需要帮助来确定如何确保删除接收时间的“最新”副本。

Sub RemoveDuplicates()
    Dim oFolder As Folder
    Dim oEmail As MailItem, oItems As ItemProperties, oItem As ItemProperty
    Dim cMail As Collection
    Dim i As Long
    Set oFolder = Application.ActiveExplorer.CurrentFolder
    Set cMail = New Collection

    With oFolder
        ' .Items.Sort "[ReceivedTime]", True
        If olMailItem <> .DefaultItemType Then Exit Sub
        For i = .Items.Count To 1 Step -1
            Set oItems = .Items(i).ItemProperties
            Debug.Print oItems("ReceivedTime")

            If Not oItems("ReceivedTime") Is Nothing Then
                Set oItem = oItems("ReceivedTime")

                '// Week old
                If oItem >= Date - 7 Then
                    On Error GoTo ErrHandler
                    '// Delete Duplicate Subject
                    cMail.Add oItems("Subject"), oItems("Subject")
                    On Error GoTo 0
                End If
            End If
        Next i
    End With

    Exit Sub

ErrHandler:
    Debug.Print Err.Number, oItems("Subject"), oItems("ReceivedTime")
    oFolder.Items(i).Delete

    Resume Next
End Sub

Answer 1

在进入循环之前缓存 Items 集合（否则每次都会得到一个全新的 Items COM 对象），按 ReceivedTime (Items.Sort) 对其进行排序，然后从 Count 向下循环到 1。

Answer 2

扩展@DmitryStreblechenko 的回答：

以下将保留日期最旧的MailItem，并删除具有相同主题的较新日期。

为方便起见，TargetFolder 和 MinDate 是可配置但可选的。它们默认为当前可见的文件夹和 7 天前。

Sub RemoveDuplicates(Optional TargetFolder As Folder, Optional MinDate As Date)
    Dim Items As Items, Email As MailItem
    Dim i As Long, Dupes As Object

    If MinDate = vbEmpty Then MinDate = Date - 7
    If TargetFolder Is Nothing Then Set TargetFolder = ActiveExplorer.CurrentFolder

    Set Dupes = CreateObject("Scripting.Dictionary")
    Set Items = TargetFolder.Items
    Items.Sort "[ReceivedTime]"

    Debug.Print "Dedupe <" & TargetFolder.FolderPath & ">, " & Items.Count & " items"

    For i = Items.Count To 1 Step -1
        If TypeOf Items(i) Is MailItem Then
            Set Email = Items(i)
            If Email.ReceivedTime >= MinDate Then
                If Dupes.Exists(Email.Subject) Then
                    Debug.Print "DELETE: " & Email.Subject
                    'Item.Delete
                Else
                    Dupes.Add Email.Subject, 0
                End If
            End If
        End If
    Next i
End Sub

这使用了Scripting.Dictionary，因为与Collection 对象不同，它支持方便的Exists() 方法。