刪除重複的郵件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

回答

相關問題