Option
Explicit
Sub
VBA_Export_Outlook_Emails_To_Excel()
Dim
Folder
As
Outlook.MAPIFolder
Dim
sFolders
As
Outlook.MAPIFolder
Dim
iRow
As
Integer
, oRow
As
Integer
Dim
MailBoxName
As
String
, Pst_Folder_Name
As
String
MailBoxName =
"Test@example.de"
Pst_Folder_Name =
"Test"
For
Each
Folder
In
Outlook.Session.Folders(MailBoxName).Folders
If
VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name)
Then
GoTo
Label_Folder_Found
For
Each
sFolders
In
Folder.Folders
If
VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name)
Then
Set
Folder = sFolders
GoTo
Label_Folder_Found
End
If
Next
sFolders
Next
Folder
Label_Folder_Found:
If
Folder.Name =
""
Then
MsgBox
"Invalid Data in Input"
GoTo
End_Lbl1:
End
If
ThisWorkbook.Sheets(1).Activate
ThisWorkbook.Sheets(1).Cells(1, 1) =
"Sender"
ThisWorkbook.Sheets(1).Cells(1, 2) =
"Termin"
ThisWorkbook.Sheets(1).Cells(1, 3) =
"Zugesagt / Abgesagt"
ThisWorkbook.Sheets(1).Cells(1, 4) =
"Betreff"
ThisWorkbook.Sheets(1).Cells(1, 5) =
"Datum"
ThisWorkbook.Sheets(1).Cells(1, 6) =
"EmailID"
oRow = 1
For
iRow = 1
To
Folder.Items.Count
If
VBA.DateValue(VBA.Now) - VBA.DateValue(Folder.Items.Item(iRow).ReceivedTime) <= 60
Then
oRow = oRow + 1
ThisWorkbook.Sheets(1).Cells(oRow, 1).
Select
ThisWorkbook.Sheets(1).Cells(oRow, 1) = Folder.Items.Item(iRow).SenderName
ThisWorkbook.Sheets(1).Cells(oRow, 2) = Folder.Items.Item(iRow).Subject
ThisWorkbook.Sheets(1).Cells(oRow, 5) = Folder.Items.Item(iRow).ReceivedTime
ThisWorkbook.Sheets(1).Cells(oRow, 6) = Folder.Items.Item(iRow).SenderEmailAddress
End
If
Next
iRow
MsgBox
"Mails wurden erfolgreich exportiert"
Set
Folder =
Nothing
Set
sFolders =
Nothing
End_Lbl1:
End
Sub