AW: Inhalte aus Emails importieren.
18.11.2008 09:53:35
Tino
Hallo,
bei mir funktioniert es so, weis aber nicht wie die Meldung von Deinem Provider aussieht.
Vielleicht wäre es auch ratsam, sollte Dein Posteingang sehr viele Mails enthalten, diese mit Regeln in einen anderen Ordner zu verfrachten, weil dieses Makro jede Mail im Posteingang untersucht.
Option Explicit
Sub Mail_Untersuchen()
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
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 = "mail delivery failed: returning message to sender"
With Application
.ScreenUpdating = False
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
Set objFolder = objnSpace.Folders("Persönliche Ordner").Folders("Posteingang") '
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
On Error GoTo 1
sTxt = objFolder.Items(intCounter).body
sTxt = Right$(sTxt, Len(sTxt) - InStr(sTxt, "failed:") - 7)
sTxt = Left$(sTxt, InStr(sTxt, "SMTP") - 1)
sTxt = Replace(Replace(sTxt, ">", ""), "<", "")
sTxt = Replace(Replace(sTxt, " ", ""), " ", "")
Cells(lRow, "A") = .WorksheetFunction.Clean(sTxt)
lRow = lRow + 1
1 If Err.Number <> 0 Then On Error GoTo 0: Err.Number = 0
End If
Next intCounter
End If
.StatusBar = False
.ScreenUpdating = True
End With
Set objnSpace = Nothing
Set objFolder = Nothing
Set objOutlook = Nothing
End Sub
Gruß Tino