Email Adresse aus Email Text extrahieren
Stephan
ich habe ein Skript, das mit Version Office 2007 wunderbar funktionierte, bei der Version 2010 aber aus irgendeinem Grund scheitert.
Ich will aus Emails, eine Email Adresse Extrahieren, die im Email Text angegeben ist. Es sind Mails, die als unzustellbar zurück kommen.
Kann mir jemand sagen, wo der Fehler liegt?
Die Mails liegen alle im Folder Junk-E-Mail.
Daaanke vorweg für die Hilfe.
Hier das Skript:
Option Explicit
'Option Explicit
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