Schluss mit Weiterleiten und Abtippen: Gesendete Mails per Makro neu verschicken

Der Kunde hat nicht reagiert, der Kollege findet die Mail angeblich nicht mehr, oder Sie möchten eine wichtige Information einfach noch einmal in Erinnerung rufen? Statt die gesendete Nachricht mühsam weiterzuleiten, Empfänger neu einzutragen und den Text aufzuräumen, erledigt ein kleines Makro das für Sie: Es erstellt aus einer gesendeten E-Mail mit einem Klick eine neue Nachricht – mit denselben Empfängern, demselben Text und denselben Anhängen.

1. Ziel des Makros

Das Makro übernimmt eine oder mehrere markierte Nachrichten aus dem Ordner Gesendete Elemente (oder die gerade geöffnete gesendete Nachricht) und baut daraus jeweils eine neue, sendefähige E-Mail. Übernommen werden:

• alle Empfänger mit ihrer ursprünglichen Rolle (An, Cc, Bcc),
• der Nachrichtentext im Originalformat (HTML, Rich Text oder Nur-Text),
• Datei- und Elementanhänge sowie eingebettete Bilder,
• Wichtigkeit, Vertraulichkeit sowie angeforderte Lese- und Übermittlungsbestätigungen,
• das Absenderkonto, sofern Outlook es für die gesendete Nachricht liefert.

Auf Wunsch stellt das Makro dem Betreff einen Zusatz wie „Erinnerung:“ voran. Im Testmodus wird die neue Nachricht nur angezeigt, damit Sie alles prüfen können. Ist der Testmodus abgeschaltet, fragt das Makro vor jedem Versand ausdrücklich nach.

Klassisches Outlook bietet zwar im geöffneten Nachrichtenfenster unter Aktionen den Befehl Diese Nachricht erneut senden. Dafür müssen Sie die Nachricht aber jedes Mal öffnen, und eine Mehrfachauswahl ist nicht möglich. Das Makro arbeitet direkt aus der Nachrichtenliste heraus und lässt sich auf eine Schaltfläche legen.

Wichtig: VBA-Makros funktionieren nur im klassischen Outlook für Windows (Microsoft 365, Outlook 2021, 2019, 2016). Das neue Outlook für Windows sowie Outlook im Web und auf dem Mac unterstützen kein VBA.

2. Technische Umsetzung

Das Makro nutzt ausschließlich das Outlook-Objektmodell. Der Ablauf im Überblick:

1. Auswahl ermitteln: Ist ein Nachrichtenfenster aktiv (Inspector), wird dessen Element verwendet, sonst die Markierung im Hauptfenster (Explorer.Selection).
2. Prüfen: Verarbeitet werden nur Elemente vom Typ MailItem, deren Eigenschaft Sent auf True steht. Termine, Besprechungsanfragen oder Entwürfe werden übersprungen.
3. Neue Nachricht erstellen: Mit Application.CreateItem(olMailItem) entsteht eine leere E-Mail, in die Text, Empfänger und Optionen übertragen werden.
4. SMTP-Adressen auflösen: Bei Exchange-Empfängern liefert Recipient.Address oft eine interne X.500-Adresse. Das Makro liest deshalb zuerst die SMTP-Adresse über den PropertyAccessor aus.
5. Anhänge kopieren: Anhänge lassen sich nicht direkt von einer Nachricht in eine andere verschieben. Das Makro speichert sie daher in einem eigenen Arbeitsordner im TEMP-Verzeichnis, fügt sie der neuen Nachricht hinzu und entfernt die temporären Kopien anschließend. Die Content-ID eingebetteter Bilder wird mitkopiert, damit Grafiken im HTML-Text sichtbar bleiben.
6. Abschließen: Anzeigen (Testmodus) oder Senden nach Rückfrage.

32 und 64 Bit: Der Code verwendet keine Windows-API-Aufrufe (Declare-Anweisungen) und läuft daher ohne Anpassungen in 32- und 64-Bit-Versionen von Outlook. Andere Office-Programme werden nicht angesprochen, zusätzliche Verweise im VBA-Editor sind nicht nötig.

Beachten Sie: Das Makro erzeugt eine neue Nachricht. Sie erhält eine neue Nachrichten-ID und erscheint beim Empfänger als eigenständige E-Mail, nicht als Teil der ursprünglichen Unterhaltung. Abstimmungsschaltflächen und Nachverfolgungskennzeichen werden nicht übernommen.

3. Vollständiger VBA-Code

Fügen Sie den folgenden Code vollständig in ein neues Standardmodul ein:

Option Explicit

' ============================================================
' Gesendete Nachricht als neue E-Mail erneut senden
' Für klassisches Outlook unter Windows (32 und 64 Bit)
' ============================================================

' True  = neue Nachricht nur anzeigen (empfohlen für die ersten Tests)
' False = vor dem Senden eine Rückfrage anzeigen
Private Const TESTMODUS As Boolean = True

' Text, der dem Betreff vorangestellt wird ("" = Betreff unverändert)
Private Const BETREFF_ZUSATZ As String = "Erinnerung: "

' MAPI-Eigenschaften für SMTP-Adresse und Content-ID eingebetteter Bilder
Private Const PR_SMTP_ADDRESS As String = _
    "http://schemas.microsoft.com/mapi/proptag/0x39FE001F"
Private Const PR_ATTACH_CONTENT_ID As String = _
    "http://schemas.microsoft.com/mapi/proptag/0x3712001F"

Private Const TITEL As String = "Erneut senden"

Public Sub GesendeteNachrichtErneutSenden()
    Dim auswahl As Collection
    Dim element As Object
    Dim quelle As Outlook.MailItem
    Dim neueMail As Outlook.MailItem
    Dim anzahlVerarbeitet As Long
    Dim anzahlUebersprungen As Long

    On Error GoTo Fehler

    Set auswahl = AusgewaehlteElemente()

    If auswahl.Count = 0 Then
        MsgBox "Bitte markieren oder öffnen Sie zuerst eine gesendete Nachricht.", _
               vbExclamation, TITEL
        Exit Sub
    End If

    If auswahl.Count > 1 Then
        If MsgBox(auswahl.Count & " Elemente sind markiert. Sollen alle verarbeitet werden?", _
                  vbQuestion + vbYesNo + vbDefaultButton2, TITEL) <> vbYes Then
            Exit Sub
        End If
    End If

    For Each element In auswahl
        If TypeOf element Is Outlook.MailItem Then
            Set quelle = element
            If quelle.Sent Then
                Set neueMail = NeueNachrichtAusQuelle(quelle)
                NachrichtAbschliessen neueMail
                anzahlVerarbeitet = anzahlVerarbeitet + 1
            Else
                anzahlUebersprungen = anzahlUebersprungen + 1
            End If
        Else
            anzahlUebersprungen = anzahlUebersprungen + 1
        End If
    Next element

    If anzahlUebersprungen > 0 Then
        MsgBox anzahlVerarbeitet & " Nachricht(en) verarbeitet, " & _
               anzahlUebersprungen & " Element(e) übersprungen " & _
               "(keine gesendete E-Mail).", vbInformation, TITEL
    End If
    Exit Sub

Fehler:
    MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical, TITEL
End Sub

' Liefert das geöffnete Element bzw. die markierten Elemente
Private Function AusgewaehlteElemente() As Collection
    Dim ergebnis As New Collection
    Dim fensterTyp As String
    Dim i As Long

    On Error Resume Next
    fensterTyp = TypeName(Application.ActiveWindow)
    On Error GoTo 0

    If fensterTyp = "Inspector" Then
        ergebnis.Add Application.ActiveInspector.CurrentItem
    ElseIf fensterTyp = "Explorer" Then
        With Application.ActiveExplorer.Selection
            For i = 1 To .Count
                ergebnis.Add .Item(i)
            Next i
        End With
    End If

    Set AusgewaehlteElemente = ergebnis
End Function

' Baut aus der gesendeten Nachricht eine neue, sendefähige E-Mail
Private Function NeueNachrichtAusQuelle(ByVal quelle As Outlook.MailItem) As Outlook.MailItem
    Dim neueMail As Outlook.MailItem
    Dim empfaenger As Outlook.Recipient
    Dim neuerEmpfaenger As Outlook.Recipient
    Dim betreff As String

    Set neueMail = Application.CreateItem(olMailItem)

    ' Absenderkonto übernehmen, sofern Outlook es liefert
    On Error Resume Next
    If Not quelle.SendUsingAccount Is Nothing Then
        Set neueMail.SendUsingAccount = quelle.SendUsingAccount
    End If
    On Error GoTo 0

    ' Nachrichtentext im Originalformat übernehmen
    Select Case quelle.BodyFormat
        Case olFormatHTML
            neueMail.BodyFormat = olFormatHTML
            neueMail.HTMLBody = quelle.HTMLBody
        Case olFormatRichText
            neueMail.BodyFormat = olFormatRichText
            neueMail.RTFBody = quelle.RTFBody
        Case Else
            neueMail.BodyFormat = olFormatPlain
            neueMail.Body = quelle.Body
    End Select

    ' Empfänger mit ihrer Rolle (An, Cc, Bcc) übernehmen
    For Each empfaenger In quelle.Recipients
        Set neuerEmpfaenger = neueMail.Recipients.Add(SmtpAdresse(empfaenger))
        neuerEmpfaenger.Type = empfaenger.Type
    Next empfaenger
    neueMail.Recipients.ResolveAll

    ' Betreff ergänzen, ohne den Zusatz doppelt einzufügen
    betreff = quelle.Subject
    If Len(BETREFF_ZUSATZ) > 0 Then
        If LCase$(Left$(betreff, Len(BETREFF_ZUSATZ))) <> LCase$(BETREFF_ZUSATZ) Then
            betreff = BETREFF_ZUSATZ & betreff
        End If
    End If
    neueMail.Subject = betreff

    ' Weitere Optionen übernehmen
    neueMail.Importance = quelle.Importance
    neueMail.Sensitivity = quelle.Sensitivity
    neueMail.ReadReceiptRequested = quelle.ReadReceiptRequested
    neueMail.OriginatorDeliveryReportRequested = quelle.OriginatorDeliveryReportRequested

    AnhaengeUebernehmen quelle, neueMail
    neueMail.Save

    Set NeueNachrichtAusQuelle = neueMail
End Function

' Kopiert Datei- und Elementanhänge über einen temporären Ordner
Private Sub AnhaengeUebernehmen(ByVal quelle As Outlook.MailItem, ByVal ziel As Outlook.MailItem)
    Dim anhang As Outlook.Attachment
    Dim neuerAnhang As Outlook.Attachment
    Dim basisOrdner As String
    Dim unterOrdner As String
    Dim dateiName As String
    Dim dateiPfad As String
    Dim nummer As Long
    Dim zaehler As Long

    If quelle.Attachments.Count = 0 Then Exit Sub

    ' Eindeutigen Arbeitsordner im TEMP-Verzeichnis anlegen
    Do
        zaehler = zaehler + 1
        basisOrdner = Environ$("TEMP") & "\OutlookErneutSenden_" & _
                      Format$(Now, "yyyymmdd_hhnnss") & "_" & zaehler
    Loop While Len(Dir$(basisOrdner, vbDirectory)) > 0
    MkDir basisOrdner

    For Each anhang In quelle.Attachments
        nummer = nummer + 1
        Select Case anhang.Type
            Case olByValue, olEmbeddeditem
                dateiName = DateinameBereinigen(anhang.FileName)
                If Len(dateiName) = 0 Then dateiName = "Anhang_" & nummer
                If anhang.Type = olEmbeddeditem Then
                    If LCase$(Right$(dateiName, 4)) <> ".msg" Then dateiName = dateiName & ".msg"
                End If

                ' Eigener Unterordner verhindert Konflikte bei gleichen Dateinamen
                unterOrdner = basisOrdner & "\" & nummer
                MkDir unterOrdner
                dateiPfad = unterOrdner & "\" & dateiName

                anhang.SaveAsFile dateiPfad
                Set neuerAnhang = ziel.Attachments.Add(dateiPfad, olByValue)
                InhaltsIdUebertragen anhang, neuerAnhang
            Case Else
                ' Verknüpfte Dateien und OLE-Objekte werden nicht übernommen
                Debug.Print "Nicht übernommen: " & anhang.DisplayName
        End Select
    Next anhang

    ' Erst speichern, dann die temporären Kopien entfernen
    ziel.Save
    TempOrdnerEntfernen basisOrdner
End Sub

' Überträgt die Content-ID, damit eingebettete Bilder sichtbar bleiben
Private Sub InhaltsIdUebertragen(ByVal alt As Outlook.Attachment, ByVal neu As Outlook.Attachment)
    Dim inhaltsId As String
    On Error Resume Next
    inhaltsId = alt.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID)
    If Len(inhaltsId) > 0 Then
        neu.PropertyAccessor.SetProperty PR_ATTACH_CONTENT_ID, inhaltsId
    End If
End Sub

' Ermittelt die SMTP-Adresse, auch bei Exchange-Empfängern
Private Function SmtpAdresse(ByVal empfaenger As Outlook.Recipient) As String
    Dim adresse As String
    On Error Resume Next
    adresse = empfaenger.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
    On Error GoTo 0
    If Len(adresse) = 0 Then adresse = empfaenger.Address
    If Len(adresse) = 0 Then adresse = empfaenger.Name
    SmtpAdresse = adresse
End Function

' Ersetzt Zeichen, die in Windows-Dateinamen nicht erlaubt sind
Private Function DateinameBereinigen(ByVal eingabe As String) As String
    Dim verboten As Variant
    Dim zeichen As Variant
    verboten = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    For Each zeichen In verboten
        eingabe = Replace(eingabe, zeichen, "_")
    Next zeichen
    DateinameBereinigen = Trim$(eingabe)
End Function

' Löscht ausschließlich den vom Makro angelegten Arbeitsordner
Private Sub TempOrdnerEntfernen(ByVal basisOrdner As String)
    Dim eintrag As String
    Dim ordnerListe As New Collection
    Dim pfad As Variant

    On Error Resume Next
    eintrag = Dir$(basisOrdner & "\*", vbDirectory)
    Do While Len(eintrag) > 0
        If eintrag <> "." And eintrag <> ".." Then
            ordnerListe.Add basisOrdner & "\" & eintrag
        End If
        eintrag = Dir$()
    Loop

    For Each pfad In ordnerListe
        Kill pfad & "\*.*"
        RmDir pfad
    Next pfad
    RmDir basisOrdner
End Sub

' Zeigt die Nachricht an oder sendet sie nach Bestätigung
Private Sub NachrichtAbschliessen(ByVal neueMail As Outlook.MailItem)
    Dim antwort As VbMsgBoxResult

    If TESTMODUS Then
        neueMail.Display
        Exit Sub
    End If

    If Not neueMail.Recipients.ResolveAll Then
        MsgBox "Mindestens ein Empfänger konnte nicht aufgelöst werden. " & _
               "Die Nachricht wird zur Prüfung angezeigt.", vbExclamation, TITEL
        neueMail.Display
        Exit Sub
    End If

    antwort = MsgBox("Diese Nachricht jetzt erneut senden?" & vbCrLf & vbCrLf & _
                     "Betreff: " & neueMail.Subject & vbCrLf & _
                     "An: " & neueMail.To & vbCrLf & _
                     "Cc: " & neueMail.CC & vbCrLf & _
                     "Bcc: " & neueMail.BCC & vbCrLf & _
                     "Anhänge: " & neueMail.Attachments.Count & vbCrLf & vbCrLf & _
                     "Ja = senden, Nein = anzeigen, Abbrechen = als Entwurf behalten", _
                     vbQuestion + vbYesNoCancel + vbDefaultButton2, TITEL)

    Select Case antwort
        Case vbYes
            neueMail.Send
        Case vbNo
            neueMail.Display
        Case Else
            ' Nachricht bleibt im Ordner "Entwürfe"
    End Select
End Sub

4. Code-Erklärung

5. Installation

1. Öffnen Sie im klassischen Outlook mit Alt+F11 den VBA-Editor.
2. Wählen Sie im Projekt-Explorer Project1 (VbaProject.OTM) und anschließend Einfügen > Modul. Das Makro nutzt keine Ereignisse, deshalb gehört es in ein Standardmodul und nicht in ThisOutlookSession.
3. Benennen Sie das Modul im Eigenschaftenfenster (F4) zum Beispiel in modErneutSenden um und fügen Sie den Code ein.
4. Prüfen Sie den Code mit Debuggen > Kompilieren von Project1 und speichern Sie mit Strg+S.
5. Kontrollieren Sie die Makrosicherheit unter Datei > Optionen > Trust Center > Einstellungen für das Trust Center > Makroeinstellungen. Empfehlenswert ist „Benachrichtigungen für digital signierte Makros, alle anderen Makros deaktivieren“ in Verbindung mit einem eigenen Zertifikat (Programm SelfCert.exe aus dem Office-Verzeichnis, im VBA-Editor unter Extras > Digitale Signatur zuweisen).
6. Starten Sie Outlook neu, damit die Einstellungen greifen.

6. Ausführung

Markieren Sie im Ordner Gesendete Elemente eine oder mehrere Nachrichten oder öffnen Sie eine gesendete Nachricht. Drücken Sie Alt+F8, wählen Sie GesendeteNachrichtErneutSenden und klicken Sie auf Ausführen.

Bequemer ist eine Schaltfläche:

• Menüband: Datei > Optionen > Menüband anpassen, rechts eine neue Gruppe anlegen, links unter „Befehle auswählen“ Makros wählen und das Makro hinzufügen. Über Umbenennen vergeben Sie einen verständlichen Namen und ein Symbol.
• Symbolleiste für den Schnellzugriff: Datei > Optionen > Symbolleiste für den Schnellzugriff, ebenfalls Makros auswählen und hinzufügen.
• Im Nachrichtenfenster: Öffnen Sie eine gesendete Nachricht und passen Sie dort das Menüband bzw. die Schnellzugriffsleiste an. Diese Einstellungen gelten getrennt vom Hauptfenster.

Lassen Sie den Testmodus aktiv, bis Sie einige Nachrichten geprüft haben – insbesondere solche mit Anhängen, eingebetteten Bildern und Bcc-Empfängern. Erst danach setzen Sie TESTMODUS auf False.

7. Fehlerbehebung

8. Erweiterungen

• Nur an Nicht-Antwortende: Gleichen Sie die Empfänger mit eingegangenen Antworten derselben Unterhaltung ab (ConversationID) und entfernen Sie Personen, die bereits geantwortet haben.
• Einleitungstext: Fügen Sie vor dem Originaltext einen kurzen Hinweis ein, etwa „Ich möchte Sie an meine Nachricht vom … erinnern“, und verwenden Sie dafür quelle.SentOn.
• Freigegebene Postfächer: Wenn Sie im Auftrag eines anderen Postfachs senden, übernehmen Sie zusätzlich SentOnBehalfOfName.
• Bcc ausblenden: Soll eine Erinnerung nur an die sichtbaren Empfänger gehen, überspringen Sie in der Empfängerschleife alle Einträge mit Type = olBCC.
• Zeitversetztes Senden: Mit neueMail.DeferredDeliveryTime verlassen Erinnerungen erst zu einer bestimmten Uhrzeit den Postausgang.

9. Sicherheitshinweise

• Senden ist nicht umkehrbar. Lassen Sie den Testmodus aktiv, bis das Ergebnis für Ihre Nachrichten zuverlässig stimmt. Auch ohne Testmodus fragt das Makro vor jedem Versand nach; die vorgewählte Antwort ist „Nein“ (nur anzeigen).
• Prüfen Sie besonders bei Mehrfachauswahl und Bcc-Empfängern, wer die Nachricht erhält. Ein unbedacht wiederholter Versand an große Verteiler wirkt schnell wie Spam.
• Die gesendete Originalnachricht wird nicht verändert oder gelöscht. Das Makro löscht ausschließlich die eigenen temporären Dateien im TEMP-Verzeichnis.
• Vertrauliche Anhänge liegen kurzzeitig als Datei im TEMP-Ordner. Bricht das Makro mit einem Fehler ab, können dort Kopien zurückbleiben – kontrollieren Sie den Ordner in diesem Fall.
• Verwenden Sie nur Makros, deren Code Sie nachvollziehen können, und signieren Sie eigene Makros, statt die Makrosicherheit allgemein herabzusetzen.
• Bitte testen Sie den Code vor dem produktiven Einsatz mit unkritischen Nachrichten, zum Beispiel einer E-Mail an sich selbst.