Email Adresse aus Email Text extrahieren

Sub GrapText()
Dim objOutlook As Object
Dim objnSpace As Object
Dim objFolder As Object
Dim intCounter As Integer, intCount As Integer, lRow As Long
Dim sTxt As String, Text As String
Dim strAr1, strAr2, i As Integer
Cells(1, "A") = "Mailaddressen": Cells(1, "A").Font.Bold = True
lRow = 2 'ab welcher Zeile einfügen
'   hier der Text der im Betreff vorkommt
Text = LCase("Undelivered Mail Returned to Sender")
With Application
.ScreenUpdating = False
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
Set objFolder = objnSpace.Folders("Persönlicher Ordner").Folders("Junk-E-Mail") 'Persö _
nlicher Ordner
intCount = objFolder.Items.Count
If intCount > 0 Then
For intCounter = intCount To 1 Step -1
.StatusBar = "Bitte warten, es werten noch " & intCounter & " E-Mails untersucht"
If InStr(1, LCase(objFolder.Items(intCounter).Subject), Text) > 0 Then
sTxt = objFolder.Items(intCounter).body
strAr1 = Split(sTxt, "")
Cells(lRow, "A") = Cells(lRow, "A") & strAr2(LBound(strAr2)) & ";"
Next i
lRow = lRow + 1
End If
1   If Err.Number  0 Then On Error GoTo 0: Err.Number = 0
Next intCounter
End If
.StatusBar = False
.ScreenUpdating = True
End With
Set objnSpace = Nothing
Set objFolder = Nothing
Set objOutlook = Nothing
End Sub