volker01
Goto Top

VB-Makro für Outlook gesucht - Suche Mails nach "Angezeigtem Namen" und Lösche alle bis auf die neuesten Anzahl n

Hallo,

ich erhalte täglich Mails mit Sicherungs-Logs und suche ein VB-Makro das folgendes können soll:

Suche - in einer pst in einem Ordner der Wahl - nach Mails.
Durchsuche diesen Ordner nach "Angezeigte Namen" und Lösche von jedem anzeigten Namen alle Mails – bis auf die n neuesten.

Absender- und Empfänger Adresse sind bei allen Mails gleich.
Die eingehenden Mails werden bei Eintreffen von einer Outlook Regel geprüft
und in eine andere PST mit Namen „KundenSicherungen“ dort in einen Unterordner mit Namen „_Alle“ verschoben.

Wer kann helfen?

Viele Grüße
Volker

Content-Key: 260330

Url: https://administrator.de/contentid/260330

Ausgedruckt am: 28.03.2024 um 12:03 Uhr

Mitglied: colinardo
colinardo 18.01.2015 aktualisiert um 18:31:03 Uhr
Goto Top
Hallo Volker,
lässt sich machen face-smile
Das sieht dann z.B. so aus ... (Kommentare findest du im Code)
Sub keepNewestXMailsFromIndividualSenders()
    Dim folderMails As Folder, mail As MailItem, dic As Object, intKeep As Integer, itms As items, x As Integer, i As Integer, keys As Variant
    'Anzahl Mails die pro Sendername erhalten bleiben sollen  
    intKeep = 5
    'Dictionary  
    Set dic = CreateObject("Scripting.Dictionary")  
    'Ordner aus dem die Mails verarbeitet werden  
    Set folderMails = Application.Session.Stores("KundenSicherungen").GetRootFolder.Folders("_Alle")  
    
    'lade alle individuellen Sendernamen in ein Dictionary  
    For Each mail In folderMails.items
        If Not dic.Exists(mail.SenderName) Then
            dic.add mail.SenderName, ""  
        End If
    Next
    
    'Iteriere über das Dictionary  
    keys = dic.keys
    For i = 0 To dic.count - 1
        'Mails nach Sendername filtern  
        Set itms = folderMails.items.Restrict("[Sendername] = '" & keys(i) & "'")  
        If Not itms Is Nothing Then
            ' wenn die Anzahl der zu behaltenen Mails den angegebenen Wert übersteigt  
            If itms.count > intKeep Then
                'Mails nach Datum absteigend sortieren  
                itms.Sort "[ReceivedTime]", True  
                'Überzählige Mails des Sendernamens löschen  
                For x = itms.count To intKeep + 1 Step -1
                    itms.Item(x).Delete
                Next
            End If
        End If
    Next
    Set dic = Nothing
End Sub
Grüße Uwe
Falls der Beitrag gefällt, seid so nett und unterstützt mich durch eine kleine Spende / If you like my contribution please support me and donate
Mitglied: volker01
volker01 18.01.2015 um 19:21:15 Uhr
Goto Top
Hallo colinardo,

bis restlos begeistert.
funktioniert wie gewünscht.

Viele Grüße
Volker

PS: Spende ist unterwegs.
Mitglied: colinardo
colinardo 18.01.2015 aktualisiert um 19:24:32 Uhr
Goto Top
Hallo Volker,
bis restlos begeistert.
funktioniert wie gewünscht.
freut mich face-smile
PS: Spende ist unterwegs.
Herzlichen Dank !! face-big-smile

Viel Erfolg weiterhin.
Grüße Uwe