Question

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

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

基本上我需要帮助弄清楚如何确保＆＃34;最新的＆＃34;收到的时间重复被删除。

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是可配置的，但是可选的。它们默认为七天前的当前可见文件夹。

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()方法。

删除重复的邮件Outlook 2013

2 个答案: