Löschen von doppelten E-Mails Outlook 2013

Question

Ich versuche, einen VBA-Makro zu erstellen, der prüft, ob es eine doppelte E-Mail gibt (schaut auf Betreff) und löscht dann die E-Mail.

Dieser Code funktioniert, löscht jedoch die ältesten Duplikate. Es zählt in absteigender Reihenfolge und ich kann nicht scheinen, dass die Sortierung der Gegenstände funktioniert.

Grundsätzlich brauche ich Hilfe herauszufinden, wie Sie sicherstellen, dass die "neueste" Duplikat nach erhalten Zeit gelöscht wird.

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

Expanding on @ DmitryStreblechenkos Antwort:

Das folgende wird die MailItem mit dem ältesten Datum behalten und neuere mit dem gleichen Thema löschen.

Für die Bequemlichkeit TargetFolder und MinDate sind konfigurierbar, aber optional. Sie sind standardmäßig auf den derzeit sichtbaren Ordner und vor sieben Tagen eingestellt.

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 

Dies macht die Verwendung eines Scripting.Dictionary weil im Gegensatz zu dem Collection Objekt, um es ein handliches Exists() Methode unterstützt.

Answer 2

Cache der Items-Auflistung vor die Schleife eintritt (sonst bekommen Sie eine brandneue Elemente COM jedes Mal Objekt), sortieren sie auf ReceivedTime (Items.Sort), dann von der Schleife Count down bis 1.