Mail Delivery Error - Schluss mit einzeln rauskopieren

Outlook 2010

Liebe Kollegen,

ich hoffe das mit dieser Anleitung auch einige Leute etwas anfangen können. Wir betreiben ein Newsletter-System welches regelmäßig verwendet wird. Hin und wieder kommt es vor (aus Altbeständen) das einige Adressen nicht mehr gültig sind und mit einer Mail Delivery Error Meldung zurück kommen. Je nach Anzahl kann dies sehr mühselig sein alle E-Mail Adressen rauszukopieren und zu analysieren.

Vor diesem Problem stand ich und möchte mich recht Herzlich bei @colinardo bedanken, der mir die Lösung präsentierte. Hierbei werden alle E-Mails überprüft und die in der Fehlermeldung erhaltenen E-Mailadressen in eine separate Textdatei gespeichert.

1. Öffnet Outlook 2010
2. Verschiebt die Mail Delivery Error Meldungen in einen seperaten Ordner, am besten in das Root-Verzeichnis
3. Mit ALT + F11 könnt Ihr den VBA Editor öffnen
4. Hier bei Projekt 1 bis zur ThisOutlookSession durchklicken und nachfolgenden Code einfügen

Sub parseMails()
    Const FILEPATH = "###1###"  
    
    Set myRegExp = CreateObject("vbscript.regexp")  
    Set objFSO = CreateObject("Scripting.FileSystemObject")  
    Dim fldr As Folder
    Set fldr = Application.Session.Stores.Item("###2###").GetRootFolder.Folders("###3###")  
    Set objTextFile = objFSO.CreateTextFile(FILEPATH, True)
    myRegExp.IgnoreCase = True
    myRegExp.Pattern = "([A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,6})"  
    
    For i = 1 To fldr.Items.Count
            strBody = fldr.Items(i).Body
            Set myMatches = myRegExp.Execute(strBody)
            If myMatches.Count >= 1 Then
                For Each myMatch In myMatches
                    If myMatch.SubMatches.Count >= 1 Then
                        strEMail = myMatch.SubMatches(0)
                        objTextFile.WriteLine (strEMail)
                    End If
                Next
            End If
    Next

    objTextFile.Close
    MsgBox "Verarbeitung abgeschlossen !" & vbNewLine & "Die Datei mit den extrahierten E-Mail-Adressen liegt hier: " & FILEPATH  
    Set myRegExp = Nothing
    Set objFSO = Nothing
End Sub

###1### Hier fügt Ihr den Pfad und den Dateinamen ein, wo die Datei abgespeichert werden soll. Bei mir gab es kleine Probleme mit Laufwerk C, somit habe ich es auf D:\emails.txt geändert.

###2### Hier der Name des Root-Knoten (Stores) Eures Profils. Bei mir war es meine E-Mail Adresse.

###3### Hier den Namen des Ordners eintragen, indem Eure Meldungen liegen.

5.Script ausführen.

Hier der komplette Beitrag:
Automatisch E-Mail Adresse aus Mail Delivery Error in Textdatei kopieren

Gruß
@d4shoerncheN

Please also mark the comments that contributed to the solution of the article

Content-ID: 213199

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

Printed on: December 14, 2024 at 16:12 o'clock

1 Comment

Hi @d4shoerncheN,
danke für deine Anleitung. Zu erwähnen sei noch, dass das obige Script nur die erste E-Mail-Adresse im Body der Mail extrahiert.
Ergänzend zum obigen Script hier noch eine Variante mit der man festlegen kann an welcher Position die Mail-Adresse extrahiert werden soll:
An Position ###4### trägt man dann die Position der E-Mail-Adresse als Zahl ein.
Beispiel: Wenn im NDR-Report die gewünschte Mail-Adresse erst die dritte genannte Mail-Adresse vom Anfang aus gesehen ist trägt man hier eine 3 ein.

Sub parseMails()
    Const FILEPATH = "###1###"  
    
    Set myRegExp = CreateObject("vbscript.regexp")  
    Set objFSO = CreateObject("Scripting.FileSystemObject")  
    Dim fldr As Folder
    Set fldr = Application.Session.Stores.Item("###2###").GetRootFolder.Folders("###3###")  
    Set objTextFile = objFSO.CreateTextFile(FILEPATH, True)
    myRegExp.Global = True
    myRegExp.IgnoreCase = True
    myRegExp.Pattern = "([A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,6})"  
    
    For i = 1 To fldr.Items.Count
            strBody = fldr.Items(i).Body
            Set myMatches = myRegExp.Execute(strBody)
           If myMatches.Count > 1 Then
                intPosition = ###4###
                If myMatches(intPosition - 1).SubMatches.Count >= 1 Then
                    strEMail = myMatches(intPosition - 1).SubMatches(0)
                    objTextFile.WriteLine (strEMail)
                End If
           End If
    Next
    objTextFile.Close
    MsgBox "Verarbeitung abgeschlossen !" & vbNewLine & "Die Datei mit den extrahierten E-Mail-Adressen liegt hier: " & FILEPATH  
    Set myRegExp = Nothing
    Set objFSO = Nothing
End Sub

Grüße Uwe

German Tutorial VB for Applications Development