Hallo,

folgendes Makro muss in das Objekt "ThisOutlook Session".

Wenn dann eine Mail gesendet wird, werden Empfänger und Sender aufgrund der Liste in der Textdatei geprüft. Wenn es einen Treffer gibt, wird die Mail automatisch an die hinterlegte Mail-Adresse weitergeleitet.

Option Explicit

'Verweise
'Microsoft Scripting Runtime

'Konstanten / Einstellungen
Private Const PATH_TO_TXT_MAILADDRESS As String = "C:\Users\Benutzer\Desktop\Adressen.txt"
Private Const MAIL_ADDRESS_ARCHIV As String = "someone@somedomain.de"

'Dictionary für Mailadressen
Dim dictMail As Scripting.Dictionary

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    If Not TypeName(Item) = "MailItem" Then
        Exit Sub
    Else
        Dim mail As MailItem
        Set mail = Item
    End If
    
    If load_mail_addresses Then
        MsgBox "Konnte Mailadressen nicht aus Datei laden.", vbInformation
        Exit Sub
    End If
    
    If dictMail.Exists(mail.SenderEmailAddress) Then
        Call forward_mail(mail)
        GoTo clean_up
    End If
    
    Dim strTo() As String
    strTo = Split(mail.To, ";")
    
    Dim i As Integer
    For i = 0 To UBound(strTo)
        If dictMail.Exists(strTo(i)) Then
            Call forward_mail(mail)
            Exit For
        End If
    Next i
    
clean_up:
    If Not mail Is Nothing Then Set mail = Nothing
    If Not dictMail Is Nothing Then Set dictMail = Nothing
End Sub

Private Sub forward_mail(ByRef mail As MailItem)
    Dim nMail As MailItem
    Set nMail = mail.Forward
    
    With nMail
        .To = MAIL_ADDRESS_ARCHIV
        .Send
    End With
    
    Set nMail = Nothing
End Sub

Private Function load_mail_addresses() As Boolean
    Dim fso As New FileSystemObject
    
    If Not fso.FileExists(PATH_TO_TXT_MAILADDRESS) Then
        load_mail_addresses = True
        GoTo clean_up
    End If
    
    Dim stream As TextStream
    Dim l As Long
    Set stream = fso.OpenTextFile(PATH_TO_TXT_MAILADDRESS, ForReading, False)
    Set dictMail = New Scripting.Dictionary
    
    Do While Not stream.AtEndOfStream
        l = l + 1
        Call dictMail.Add(stream.ReadLine, l)
    Loop
    
clean_up:
    If Not stream Is Nothing Then Set stream = Nothing
    If Not fso Is Nothing Then Set fso = Nothing
End Function

Die Textdatei bzgl. der Mailadressen sieht so aus:

someone1@somedomain1.de
someone2@somedomain2.de

Gruß