Private Sub CommandButton1_Click()
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olFldr As Outlook.MAPIFolder
Dim olItem As Object
Dim olMailItem As Outlook.MailItem
Set ws = ThisWorkbook.Worksheets("Arbeitsmappe 1")
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFldr = olNS.Folders("EngOffice")
Set olFldr = olFldr.Folders("Inbox")
Set olFldr = olFldr.Folders("Deutschland") ´ZUR ABFRAGE EINES UNTERORDNERS
ws.Cells.Range("A2:D300").ClearContents
iRow = 2
Application.ScreenUpdating = False
For Each olItem In olFldr.Items
If olItem.Class = olMail Then
Set olMailItem = olItem
With olMailItem
ws.Cells(iRow, "A") = .Sender
ws.Cells(iRow, "B") = .Subject
ws.Cells(iRow, "C") = .ReceivedTime
ws.Cells(iRow, "D") = olFldr.Name
iRow = iRow + 1
End With
End If
Next olItem
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