Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
2012to2016
2012to2016
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Anzeige
Inhaltsverzeichnis

Outlook - alle Anhänge löschen mit Ausnahmen

Forumthread: Outlook - alle Anhänge löschen mit Ausnahmen

Outlook - alle Anhänge löschen mit Ausnahmen
25.06.2025 12:49:45
Wolfgang Reuter
Hallo zusammen,

ich brauche eure fachkundige Hilfe von euch zu Outlook.
Problem: Es sollen alle Anhänge der gesendeten Emails, die sich im einem Postarchiv befinden gelöscht werden. Ausnahme ist eine bestimmte Datei mit festgelegten Namen und Format.
Hintergrund ist die begrenzte Kapazität des Archivpostfaches. Das Bereinigen erfolgt am Folgetag bisher immer händisch, was natürlich unnötigen Zeitaufwand bedeutet. Ich bin auf ein Makro gestoßen, welches ich probeweise bei mir mal in Outlook mit Button ausführen kann. Das funktioniert eigentlich schon sehr gut.
Nur löscht es eben alle Anhänge. Meine Versuche mit Einfügen von SpecificAttachmentName und SpecificAttachmentExtension haben leider nicht funktioniert. Entweder passiert gar nichts oder es wird doch alles gelöscht. Bin halt zu doof dazu.

Hier mal das Ausgangsmakro, welches eben alles löscht. 

 Sub RemoveAttachmentsFromSelectedEmails()

    Dim objItem As Object

    Dim objAttachment As Attachment

    Dim strFolderPath As String

    Dim i As Long



    On Error Resume Next



    ' Schleife durch ausgewählte E-Mails im aktiven Ordner

    For Each objItem In Application.ActiveExplorer.Selection

        If objItem.Class = olMail Then

            ' Schleife durch jeden Anhang

            For i = objItem.Attachments.Count To 1 Step -1

                Set objAttachment = objItem.Attachments(i)



                ' Anhang entfernen

                objAttachment.Delete

            Next i

            objItem.Save ' Änderungen an der E-Mail speichern

        End If

    Next objItem



    On Error GoTo 0

    MsgBox "Anhänge aus den ausgewählten E-Mails entfernt."

End Sub


Vorab schon mal vielen Dank für eure Zeit und Mühe.


Anzeige

16
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Outlook - alle Anhänge löschen mit Ausnahmen
25.06.2025 13:59:05
Alwin Weisangler
Hallo Wolfgang,

ungetestet so: 



Option Explicit



Sub RemoveAttachmentsFromSelectedEmails()

    Dim objItem As Object

    Dim objAttachment As Attachment

    Dim strFolderPath As String

    Dim i As Long

    Dim NichtLoeschen$

    NichtLoeschen = "Testdatei.txt###MeinAnhang.xlsx###weitereNichtZulöschendeAnhänge###"



    On Error Resume Next



    ' Schleife durch ausgewählte E-Mails im aktiven Ordner

    For Each objItem In Application.ActiveExplorer.Selection

        If objItem.Class = olMail Then

            ' Schleife durch jeden Anhang

            For i = objItem.Attachments.Count To 1 Step -1

                Set objAttachment = objItem.Attachments(i)

                ' Anhang entfernen

                If InStr(1, objAttachment.Name, NichtLoeschen, vbTextCompare) = 0 Then objAttachment.Delete

            Next i

            objItem.Save ' Änderungen an der E-Mail speichern

        End If

    Next objItem



    On Error GoTo 0

    MsgBox "Anhänge aus den ausgewählten E-Mails entfernt."

End Sub

Den String der Variable NichtLoeschen schreibst du rein mit Trenner ### welche Anhänge nicht gelöscht werden sollen. Was ich da eingetragen habe ist beispielhaft.

Gruß Uwe
Anzeige
AW: Outlook - alle Anhänge löschen mit Ausnahmen
25.06.2025 22:19:52
Wolfgang Reuter
Hallo Uwe,

vielen Dank für deine Hilfe. Habe es ausprobiert. Leider wird die eingetragene Datei dennoch gelöscht.
Trotzdem danke ich dir für deine Mühe.

Wolfgang
AW: Outlook - alle Anhänge löschen mit Ausnahmen
26.06.2025 10:53:50
Alwin Weisangler
Hallo Wolfgang,

Falls du es nicht inzwischen selbst rausgefunden hast, ändere diese Zeile so: 


If InStr(1, NichtLoeschen, objAttachment.FileName, vbTextCompare) = 0 Then objAttachment.Delete


Gruß Uwe


Anzeige
AW: Outlook - alle Anhänge löschen mit Ausnahmen
26.06.2025 13:03:28
Wolfgang Reuter
Hallo Uwe,

vielen Dank. Das war der Fehler. Ist mir nicht aufgefallen. Und so funktioniert es nun auch.
Du bist mein Held des Tages :-)

Leider muss ich das ganze noch erweitern.
Die Anlage ist eine angehängte Email mit dem Namen: "Sie haben eine Weiterleitungsbestätigung erhalten (300 KB).msg"
Die Angabe der Größe im Namen hatte ich nicht im Kopf.
Sobald natürlich die Größenangabe im Namen sich ändert, löscht das Script natürlich trotzdem, weil der Name nicht mehr passt.
Arrghh, das hatte ich übersehen.
Gibt es eine Möglichkeit eine Art Platzhalter in der Klammer zu setzen oder nach dem Wort - erhalten? Denkbar wäre auch, einfach nur
den Dateityp "msg" nicht löschen zu lassen, denn anhängte Emails in Emails kommen nur gelegentlich vor und dürften kein entscheidenes Kapazitätsproblem verursachen.

Beste Grüße


Wolfgang
Anzeige
AW: Outlook - alle Anhänge löschen mit Ausnahmen
26.06.2025 22:22:43
Wolfgang Reuter
Hallo Uwe
Vergiss meinen Einwand mit der Angabe der KB-Größe im Dokumentnamen. War dem Umstand geschuldet, dass ich eine Beispiel-Email erst gespeichert und dann in eine Email reingezogen habe.
Funktioniert jetzt so, wie es soll.
Danke nochmal für deine tolle Unterstützung. Du hast einen doofen User richtig glücklich gemacht. :-)

Gruß

Wolfgang
Anzeige
AW: Outlook - alle Anhänge löschen mit Ausnahmen
26.06.2025 23:35:24
Alwin Weisangler
Gerne!

Gruß Uwe
AW: Outlook - alle Anhänge löschen mit Ausnahmen
25.06.2025 13:59:06
Fennek
Hallo,

der Code würde immer alle Mail im ausgewählten Ordner durchgehen. Idee: Speichern des Datums des Löschens und danach immer nur die neueren.

Prüfung auf bestimmte Anhänge mit "Attachment.Name". Es kann auch auf die Extension getestet werden.


Datum speichern:

[code]
SaveSetting "Anhaenge loeschen", now
[/code]

Datum lesen:
[code]
GetSetting "Anhaenge loeschen"
[/code]

mfg
Anzeige
AW: Outlook - alle Anhänge löschen mit Ausnahmen
25.06.2025 22:33:59
Wolfgang Reuter
So, habe mal nach einer Alternative gesucht.
Anderer Ansatz. Statt alle Dateien zu löschen lassen sich damit der Dateityp auswählen, der gelöscht wird.
Dieses Script funktioniert mit Kutools - Outlook. Beim Betätigen von dem Button erscheint eine Box in dem man den Dateityp eingeben kann, der dann bei den markierten Emails gelöscht wird.
Man kann auch die Zeile vorausgefüllt erscheinen lassen, so wie ich es mal als Beispiel eingefügt habe. Leider funktioniert das bis jetzt nur mit Eingabe eines Typs. Wenn ich mehrere gleich hintereinander eingebe, dann passiert leider nichts. Wie könnte ich die mehrere Dateitypen im einen Rutsch löschen lassen? Muss ich da ein bestimmtes Zeichen nach einem Dateityp einfügen? 

Sub DeleteSpecificTypeOfAttachments()

Dim xSelection As Outlook.Selection

Dim xItem As Object

Dim xMailItem As Outlook.MailItem

Dim xAttachment As Outlook.Attachment

Dim xFileType As String

Dim xType As String

Dim xFSO As Scripting.FileSystemObject

Dim i As Integer

On Error Resume Next

Set xSelection = Outlook.Application.ActiveExplorer.Selection

Set xFSO = New Scripting.FileSystemObject

xType = "pdf,xlsx,jpg,txt"

xType = InputBox("Dateityp):", "Kutools for Outlook", xType, 8)

If Len(Trim(xType)) = 0 Then Exit Sub

For Each xItem In xSelection

    If xItem.Class = olMail Then

        Set xMailItem = xItem

        If xMailItem.Attachments.Count > 0 Then

            For i = xMailItem.Attachments.Count To 1 Step -1

                Set xAttachment = xMailItem.Attachments.Item(i)

                xFileType = xFSO.GetExtensionName(xAttachment.FileName)

                If InStr(1, xFileType, Trim(xType), vbTextCompare) > 0 Then

                    xAttachment.Delete

                End If

            Next i

            xMailItem.Save

        End If

    End If

Next

Set xMailItem = Nothing

Set xFSO = Nothing

End Sub
Anzeige
AW: Outlook - alle Anhänge löschen mit Ausnahmen
27.06.2025 00:03:15
Wolfgang Reuter
Das ist eine gute Idee. Muss ich mal mit Einbauen.
Das erspart mir das händische Markieren der betreffenden Emails vom ganzen Tag.

Danke für den Tipp.

Gruß Wolfgang
AW: Outlook - alle Anhänge löschen mit Ausnahmen
27.06.2025 13:27:34
Wolfgang Reuter
Da es immer was zu Verbessern gibt, möchte ich noch in der geänderten Email einen Hinweistext speichern lassen.
Zum Beispiel "Die Anlagen wurden entfernt. Ihr XX-Team."
Das ist für euch bestimmt kein Problem :)

Gruß

Wolfgang
Anzeige
AW: als Outlook-VBA
27.06.2025 13:37:11
Fennek
Hallo,

als Vorlage: 


Sub T_Text_append()

Dim EML As MailItem



Set EML = ActiveExplorer.Selection(1)



EML.Body = EML.Body & vbCrLf & "Die Anlagen wurden entfernt. Ihr XX-Team."

EML.Save

End Sub


mfg
AW: als Outlook-VBA
27.06.2025 13:44:02
Wolfgang Reuter
Mann, bist du schnell!!!!

Beneidenswert, wie du das aus dem Ärmel schüttelst.
Werde sogleich ausprobieren.

Gruß

Wolfgang
Anzeige
AW: als Outlook-VBA
27.06.2025 14:02:59
Wolfgang Reuter
Funktioniert bestens.
Habe noch einen Zeilenumbruch mit "& vbCrLf & vbCrLf & _ "Ihr XX-Team." eingebaut.
Sieht hübscher aus.

Gruß

Wolfgang
AW: als Outlook-VBA
28.06.2025 00:40:31
Wolfgang Reuter
Da ich schon mal dabei war, habe ich nun noch Datum und Uhrzeit eingefügt, damit man sieht, wann die Anhänge aus den Emails gelöscht wurden. 

Sub RemoveAttachmentsFromSelectedEmails()

    Dim objItem As Object

    Dim objAttachment As Attachment

    Dim strFolderPath As String

    Dim i As Long

    Dim strDatum As String, strUhrzeit As String

    Dim EML As MailItem

    Dim NichtLoeschen$

    NichtLoeschen = "Sie haben eine Auftragsbestätigung erhalten.msg###"



Set EML = ActiveExplorer.Selection(1)



' Datum und Uhrzeit abrufen

    strDatum = Format(Date, "dd.mm.yyyy") ' z.B. 27.06.2025

    strUhrzeit = Format(Time, "hh:mm:ss") ' z.B. 14:30:00



EML.body = EML.body & vbCrLf & "Die Anlagen wurden entfernt." & vbCrLf & vbCrLf & _

                                "Ihr XX-Team."

EML.body = EML.body & vbCrLf & strDatum & ", " & strUhrzeit & " "

        

EML.Save



    On Error Resume Next



    ' Schleife durch ausgewählte E-Mails im aktiven Ordner

    For Each objItem In Application.ActiveExplorer.Selection

        If objItem.Class = olMail Then

            ' Schleife durch jeden Anhang

            For i = objItem.Attachments.Count To 1 Step -1

                Set objAttachment = objItem.Attachments(i)

                ' Anhang entfernen

                If InStr(1, NichtLoeschen, objAttachment.FileName, vbTextCompare) = 0 Then objAttachment.Delete

            Next i

            objItem.Save ' Änderungen an der E-Mail speichern

        End If

    Next objItem





    On Error GoTo 0

    MsgBox "Anhänge aus den ausgewählten E-Mails entfernt."

End Sub
Anzeige
AW: nur in der ersten Mail wird der Text angehängt!
28.06.2025 10:08:37
Fennek
Hallo,

das Anfügen des "Text wurde gelöscht" gehört in die Schleife. Ungeprüft: 

If objItem.Class = olMail Then



            ' Schleife durch jeden Anhang

objItem.body = objItem.body & vbCrLf & "Die Anlagen wurden entfernt." & vbCrLf & vbCrLf & _



                                "Ihr XX-Team." & vbCrLf & strDatum & ", " & strUhrzeit & " "

EML.Save


mfg
Anzeige
AW: nur in der ersten Mail wird der Text angehängt!
28.06.2025 16:18:58
Wolfgang Reuter
Hallo Fennek, alter Frühaufsteher :-)

Ist mir erst gar nicht aufgefallen, dass so natürlich der Hinweis nur in der ersten markierten Email geschrieben wird. Danke für den Hinweis.

Nun, habe ich das so geändert. 

Sub RemoveAttachmentsFromSelectedEmails()

    Dim objItem As Object

    Dim objAttachment As Attachment

    Dim strFolderPath As String

    Dim i As Long

    Dim strDatum As String, strUhrzeit As String

    Dim EML As MailItem

    Dim NichtLoeschen$

    NichtLoeschen = "Sie haben eine Auftragsbestätigung erhalten.msg###"

    

 ' Datum und Uhrzeit abrufen

    strDatum = Format(Date, "dd.mm.yyyy") ' z.B. 27.06.2025

    strUhrzeit = Format(Time, "hh:mm:ss") ' z.B. 14:30:00





    On Error Resume Next



    ' Schleife durch ausgewählte E-Mails im aktiven Ordner

    For Each objItem In Application.ActiveExplorer.Selection

        If objItem.Class = olMail Then

            ' Schleife durch jeden Anhang

        objItem.body = objItem.body & vbCrLf & vbCrLf & _

                                             "Die Anlagen wurden entfernt." & vbCrLf & vbCrLf & _

                                             "Ihr XX-Team." & vbCrLf & vbCrLf & _

                                             strDatum & ", " & strUhrzeit & " "

EML.Save

            For i = objItem.Attachments.Count To 1 Step -1

                Set objAttachment = objItem.Attachments(i)

                ' Anhang entfernen

                If InStr(1, NichtLoeschen, objAttachment.FileName, vbTextCompare) = 0 Then objAttachment.Delete

            Next i

            objItem.Save ' Änderungen an der E-Mail speichern

        End If

    Next objItem





    On Error GoTo 0

    MsgBox "Anhänge aus den ausgewählten E-Mails entfernt."

End Sub


Beste Grüße

Wolfgang
Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Live-Forum - Die aktuellen Beiträge
Datum
Titel
14.05.2026 13:31:09
Zeichen ausblenden
14.05.2026 09:50:42
Makro für MacOs
13.05.2026 19:14:18
Gleichheitszeichen
13.05.2026 14:24:56
VBA Projekt Passwort automatisch eingeben
13.05.2026 08:49:41
Reale Berechnung ohne Nachkommawerte
Keine passende Antwort im Forumarchiv gefunden?
Stelle deine Frage im Live-Forum