AW: Emailadressen aus EMailtext
17.06.2016 11:57:58
Stefan
Ohje, dazu hab ich echt zu wenig Erfahrung mit Exel und VBA überhaupt keine.
Danke trotzdem.
Ihatte mal diese FUnktion, aber ich bekomme immer einen Fehler:
Der Vorgang konnte nciht ausgeführt werden. Ein Objekt wurde nicht gefunden.
Markiert wird nun diese Zeile:
Set objFolder = objnSpace.Folders("123service@kochen-macht-spass.com").Folders("Junk-E-Mail") 'Persönliche Ordner
Hier das Skript:
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("123service@kochen-macht-spass.com").Folders("Junk-E-Mail") _
'Persönliche 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