VBA Outlook - Mail delivery system

Hallo zusammen,

und zwar habe ich folgendes Problem: Wir arbeiten mit einem Newslettersystem und bekommen sehr oft Emails zurück, die wie folgt aussehen:

This message was created automatically by mail delivery software.

A message that you sent could not be delivered to one or more of its recipients. This is a permanent error. The following address(es) failed:

HYPERLINK DER EMAILADRESSE
retry timeout exceeded

Nun würden ich gerne die Email-Adressen extrahiert haben, am besten in eine Excel-Tabelle.
Hier im Forum habe ich schon ein Programm gefunden, welches Emails aus den Mail delivery fails in ein Word-Dokument extrahieren soll.
Ich habe es aber nicht geschafft, dieses für unsere Ordnerstruktur umzuschreiben.
Vielleicht schafft es ja einer von euch.


Unsere Ordnerstruktur:

Öffentliche Ordner - Emailadresse des Benutzers
Alle Öffentlichen Ordner
E-Mail Versand
Carl
Berger

Das ist das Programm was ich bereits gefunden habe:

01.
Sub parseMails()
02.
Const FILEPATH = "D:\emails2.txt"
03.

04.
Set myRegExp = CreateObject("vbscript.regexp")
05.
Set objFSO = CreateObject("Scripting.FileSystemObject")
06.
Dim fldr As Folder
07.
Set fldr = Application.Session.Stores.Item("t.gerns@domain.tld").GetRootFolder.Folders("No-Reply")
08.
Set objTextFile = objFSO.CreateTextFile(FILEPATH, True)
09.
myRegExp.IgnoreCase = True
10.
myRegExp.Pattern = "([A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,6})"
11.

12.
For i = 1 To fldr.Items.Count
13.
If fldr.Items(i).Class = olMail Then
14.
strBody = fldr.Items(i).Body
15.
Set myMatches = myRegExp.Execute(strBody)
16.
If myMatches.Count >= 1 Then
17.
For Each myMatch In myMatches
18.
If myMatch.SubMatches.Count >= 1 Then
19.
strEMail = myMatch.SubMatches(0)
20.
objTextFile.WriteLine (strEMail)
21.
End If
22.
Next
23.
End If
24.
End If
25.
Next
26.

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

Danke schon mal im Voraus

Set fldr = Application.GetNamespace("MAPI").GetFefaultfolder(olPublicFoldersAllPublicFolders).Folders.Item("E-Mail Versand").Folders.Item("Carl").Folders.Item("Berger")