Option Explicit
Sub OutlookPosteingang()
Dim OLF As Outlook.MAPIFolder
Dim AnzEintraege As Long, i As Long, Email As Long
Dim lngLaufZahl As Long, lngAnzahlZeichen As Long
Dim strINHALT As String
Sheets.Add
On Error Resume Next
[A1].Value = "Betreff"
[B1].Value = "Datum Uhrzeit"
[C1].Value = "empfangen von"
[D1].Value = "gelesen"
[E1].Value = "Nachricht"
[F1].Value = "Dateianhänge"
Rows(1).Font.Bold = True
Set OLF = GetObject("", "Outlook.Application") _
.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
AnzEintraege = OLF.Items.Count
i = 0: Email = 0
While i < AnzEintraege
i = i + 1
Application.StatusBar = "Lese Posteingang " & _
Format(i / AnzEintraege, "0%")
With OLF.Items(i)
Email = Email + 1
Cells(Email + 1, 1).Value = .Subject
Cells(Email + 1, 2).Value = .ReceivedTime
Cells(Email + 1, 3).Value = .SenderName
Cells(Email + 1, 4).Value = Not .UnRead
Cells(Email + 1, 5).Value = .Body
Cells(Email + 1, 6).Value = .Attachments.Count
strINHALT = .Body
lngAnzahlZeichen = 0
For lngLaufZahl = 1 To Len(strINHALT)
If Mid(strINHALT, lngLaufZahl, 1) = "!" Then
lngAnzahlZeichen = lngAnzahlZeichen + 1
End If
Next lngLaufZahl
Cells(Email + 1, 7).Value = lngAnzahlZeichen
End With
Wend
Set OLF = Nothing
Columns("A:G").AutoFit
[A2].Select
ActiveWorkbook.Saved = True
Application.StatusBar = False
End Sub