|
Hallo
durch Zufall oder Mißgeschick sind Outlooktermine in den 'deleted' Folder verschoben worden.
Mit VBA versuchte ich die Termine auszulesen ...
With olUFolder.Items.Restrict(filter).Item(olItemsCount)
'olUFolder.Items.Restrict(filter).Item(olItemsCount) IST EIN MEETINGITEM
Set mItm = olUFolder.Items.Restrict(filter).Item(olItemsCount)
Set appt = .GetAssociatedAppointment(False)
appt.Start
...bzw...
appd.End
...bzw...
.ReminderTime
...Termine auszulesen.
Das Feld appt.Start kann auch leer sein, wenn es gesetzt ist ist es gleich zu .ReminderTime; dieses ist immer gesetzt.
In der Mail im 'deleted Folder' sind Start und Enddatum ersichtlich, das Startdatum entspricht immer der Remindertime und dem appt.Start
,wenn es gesetzt ist.
Von welchen Objekten stammt die Start-End Zeitangabe im Mail, wenn appt.Start und appd.End nicht gesetz sind.
Gruß B.Kochs
Kompletter Code:
Option Explicit
Public Sub ReadMailItems()
Dim olapp As Object
Dim olName As Object
Dim olHFolder As Object
Dim olUFolder As Object
Dim strAttCount As String
Dim olItemsCount As Long
Dim lngAttCount As Long
Dim letzteZeile As Long
Dim filter As String
Dim mItm As MeetingItem
'Dim oApp As Outlook.Application
Dim appt As Outlook.AppointmentItem
'https://documentation.help/Microsoft-Outlook-Visual-Basic-Reference/olproItemProperties.htm
'Dim objItems As Outlook.ItemProperties
'Dim objItem As Outlook.ItemProperty
'Dim objItemIdx As Integer
'Dim objItems_Collection As String
'Dim objItems_Count As Integer
On Error Resume Next
Set olapp = CreateObject("Outlook.Application")
Set olName = olapp.GetNamespace("MAPI")
Set olHFolder = olName.Session.Folders("Bernhard.Kochs@telekom.de") ' Kontoname
Set olUFolder = olHFolder.Folders("Gelöschte Elemente") 'Ordnername
filter = "[MessageClass] = " + "'IPM.Schedule.Meeting.Request'"
'letzteZeile = Sheets("Master").Range("A" & Rows.Count).End(xlUp).Row
'MsgBox letzteZeile
'Exit Sub
Sheets("Master").Select
Cells.Select
Selection.ClearContents
letzteZeile = 1
Cells(1, 1).Value = "olHFolder.Name " & Chr(13) & "->" & Chr(13) & "olUFolder.Name" 'A
Cells(1, 2).Value = "Sender-Name" 'B
Cells(1, 3).Value = "Sender-EmailAddress" 'C
Cells(1, 4).Value = "ReceivedTime" 'D
Cells(1, 5).Value = "Subject" 'E
Cells(1, 6).Value = "MeetingItems.Count" 'F
Cells(1, 7).Value = "strAttCount" 'G
Cells(1, 8).Value = "appt.Start" 'H
Cells(1, 9).Value = "appt.End" 'I
Cells(1, 10).Value = "ReminderTime" 'J
Cells(1, 11).Value = "X" 'K
'For olItemsCount = 1 To olUFolder.Items.Count
For olItemsCount = 1 To olUFolder.Items.Restrict(filter).Count
'With olUFolder.Items.Item(olItemsCount)
With olUFolder.Items.Restrict(filter).Item(olItemsCount)
Set mItm = olUFolder.Items.Restrict(filter).Item(olItemsCount)
'olUFolder.Items.Restrict(filter).Item(olItemsCount) IST EIN MEETINGITEM
For lngAttCount = 1 To .Attachments.Count
If strAttCount = "" Then
strAttCount = .Attachments.Item(lngAttCount).Filename
Else
strAttCount = strAttCount & vbCrLf & .Attachments.Item(lngAttCount).Filename
End If
Next lngAttCount
'Sheets("Master").Range("A" & olItemsCount + letzteZeile).Value = olHFolder.Name & "->" & olUFolder.Name
Cells(olItemsCount + letzteZeile, 1) = olHFolder.Name & "->" & olUFolder.Name
'Sheets("Master").Range("B" & olItemsCount + letzteZeile).Value = .SenderName
Cells(olItemsCount + letzteZeile, 2) = .SenderName
'Sheets("Master").Range("C" & olItemsCount + letzteZeile).Value = .SenderEmailAddress
Cells(olItemsCount + letzteZeile, 3) = .SenderEmailAddress
'Sheets("Master").Range("D" & olItemsCount + letzteZeile).Value = .ReceivedTime
Cells(olItemsCount + letzteZeile, 4) = .ReceivedTime
'Sheets("Master").Range("E" & olItemsCount + letzteZeile).Value = .Subject
Cells(olItemsCount + letzteZeile, 5) = .Subject
'Sheets("Master").Range("F" & olItemsCount + letzteZeile).Value = .MeetingItems.Count
Cells(olItemsCount + letzteZeile, 6) = .MeetingItems.Count
'Sheets("Master").Range("G" & olItemsCount + letzteZeile).Value = strAttCount
Cells(olItemsCount + letzteZeile, 7) = strAttCount
strAttCount = ""
'appt = request.GetAssociatedAppointment (False)
Set appt = .GetAssociatedAppointment(False)
'.ItemProperties sind die Felder vom AppointmentItem Objekt ABER auch MeetingItem Objekt
'Set objItems = .ItemProperties
'objItems_Count = objItems.Count
'If objItems_Count > 25 Then
' objItems_Count = 25
'End If
'Set objItem = objItems.Item(1) Set objItem = objItems.Item(olItemsCount)
'objItems_Collection = ""
'If (objItems.Count > 0) Then
' For objItemIdx = 0 To objItems_Count - 1
' Set objItem = objItems.Item(objItemIdx)
' If (objItem.Name <> "Body" And objItem.Name <> "EntryID") Then
' objItems_Collection = objItems_Collection & objItem.Name & "=" & objItem.Value & ";"
' End If
' Next objItemIdx
'End If
'ReminderTime ist generell Start-Datum-Zeit vom Meeting
'ggf interessant ItemProperties(n).Name
'Sheets("Master").Range("H" & olItemsCount + letzteZeile).Value = appt.Start
Cells(olItemsCount + letzteZeile, 8) = appt.Start
'Sheets("Master").Range("I" & olItemsCount + letzteZeile).Value = appt.End
Cells(olItemsCount + letzteZeile, 9) = appt.End
'ReminderTime hat nur das MeetingItem Objekt nicht das Appointment Objekt
'Sheets("Master").Range("J" & olItemsCount + letzteZeile).Value = .ReminderTime
Cells(olItemsCount + letzteZeile, 10) = .ReminderTime
'Sheets("Master").Range("K" & olItemsCount + letzteZeile).Value = "X"
Cells(olItemsCount + letzteZeile, 11) = "X"
'If (appt Is Not Null) Then
'End If
End With
Next olItemsCount
On Error GoTo 0
End Sub
|