Hallo zusammen,
ich versuche mithilfe eines Makros in Excel Emails aus Outlook zu exportieren. Hierbei handelt es sich um Antworten auf Besprechungsanfragen, also Zugesagt bzw Abgesagt. Das funktioniert zum jetzigen Zeitpunkt prima, jedoch fehlt mir eine wichtige Komponente. Die Zeit des Termins.
Ich habe leider keine Ahnung wie dieses Feld exportieren kann. Hintergrund ist, dass ich eine Auswertung fahren will, die zeigt welche Teilnehmer zum Beispiel einen Tag vor einer Besprechung bzw. in unserem Fall Schulungen abgesagt hat.
Ich hoffe jemand kann mir helfen.
Vielen Dank & viele Grüße
Jonas
Folgendes Makro habe ich aus anderen Foren und etwas angepasst:
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 condition to import mails received in last 60 days
'To import all emails, comment or remove this IF condition
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
|