Sub GrapIext()
' An den Absender Anpassen!!!
Const strAbsenderName As String = "vorname.nachname@xyz.de"
' Ende "An den Absender Anpassen!!!"
Dim objOutlook As Outlook.Application
Dim objnSpace As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim objMsg As Object
Dim objItem As Outlook.MailItem
Dim intCounter As Integer, intCount As Integer, iRow As Integer
Dim ws As Worksheet
Dim sText As String
Application.ScreenUpdating = False
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
Set objFolder = objnSpace.GetDefaultFolder(olFolderInbox)
intCount = objFolder.Items.Count
If intCount > 0 Then
Set ws = ActiveSheet
iRow = 1
For intCounter = 1 To intCount
Set objMsg = objFolder.Items(intCounter)
If objMsg.Class = olMail Then
Set objItem = objMsg
STOP
' Hier Objekt "objItem" ansehen!!!
If UCase(objItem.SenderName) = UCase(strAbsenderName) Then
iRow = iRow + 1
ws.Cells(iRow, 1).Value = objItem.Body
End If
End If
Next intCounter
Set ws = Nothing
End If
Set objnSpace = Nothing
Set objFolder = Nothing
Set objMsg = Nothing
Set objOutlook = Nothing
End Sub