删除重复的邮件Outlook 2013

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

此代码正常工作，但正在删除最早的重复项。它按降序计数，我似乎无法使项目的排序工作。

基本上我需要帮助搞清楚如何确保按接收时间重复的“最新”重复删除。

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

来源

2016-03-21 user3665785

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

来源

2016-03-21 18:18:46 Tomalak

感谢工作就像一个魅力！ Scripting.Dictionary对于其他一些宏将很方便:) – user3665785

当他发布他的答案时，我已经准备好了，我不想扔掉它。注意'TypeOf'检查和从'Items（i）'（它是'Object'）转换为'MailItem'的显式类型，这使得IntelliSense可以用于VBA IDE中的'EMail'变量。你也可以做'Objects（i）.Subject'，但是你不会自动完成。 – Tomalak

当使用它作为邮件Sub RemoveDuplicates（电子邮件为Outlook.MailItem）时，它不包括触发脚本的收到的电子邮件。假设我必须创建一个单独的事件处理程序 – user3665785

缓存进入循环前的项目集合（否则你会得到一个全新的项目COM每次对象），排序它ReceivedTime（Items.Sort），然后循环从倒计时到1

来源

2016-03-21 16:53:30

删除重复的邮件Outlook 2013

回答

相关问题