Private Sub CommandButton1_Click()
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olItem As MailItem
Dim olInbox As Outlook.MAPIFolder
Dim olFolder As Outlook.MAPIFolder
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Arbeitsmappe 1")
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
ws.Cells.Range("A2:D300").ClearContents
iRow = 2
Application.ScreenUpdating = False
For Each olItem In olInbox.Items
If olItem.Class = olMail Then
With olItem
ws.Cells(iRow, "A") = .Sender
ws.Cells(iRow, "B") = .Subject
ws.Cells(iRow, "C") = .ReceivedTime
ws.Cells(iRow, "D") = "Inbox"
iRow = iRow + 1
End With
End If
Next olItem
For Each olFolder In olInbox.Folders
For Each olItem In olFolder.Items
If olItem.Class = olMail Then
With olItem
ws.Cells(iRow, "A") = .Sender
ws.Cells(iRow, "B") = .Subject
ws.Cells(iRow, "C") = .ReceivedTime
ws.Cells(iRow, "D") = olFolder.Name
iRow = iRow + 1
End With
End If
Next
Next
With ws
hdr = Array("Sender", "Subject", " Received Time ", " Folder ", "Platzhalter")
.Range("A1").Resize(, UBound(hdr)) = hdr
.Columns.AutoFit
End With
Application.ScreenUpdating = False
End Sub