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ß
|