AW: Outlook-Termine eines Kalendertags
04.10.2013 17:48:55
fcs
Hallo Franky,
ich hab jetzt nochmals rumprobiert und intensiver getestet (Jahrestage, wöchentlicher Besprechungstermin, Termin über Mitternacht, Dienstreise ganzer Tag, mehrer Termine an einem Tag, Urlaub über mehrere Tage, mehrtägiger Termin mit Start-/Endzeit).
Ein wesentliches Problem waren ganztägige Termine. Diese wurden zunächste immer am Vortag gelistet.
Ich hab jetzt die Suche so aufgebaut, dass in einer Beschränkug zunächst alle Termine gefunden werden, die
a) am Vortag oder aktuelen Tag stattfinden oder
b) vor oder am aktuellen Tag beginnen und nach oder am aktuellen Tag enden.
Diese wurden dann auf ganztäg geprüft
Die nicht ganztägen werden dann nochmals auf das Datum geprüft, um Termine um Datumswechsel sowie nehrtägige Termine zu erkennen.
Viel Puzzlearbeit, aber ich hoffe, dass es jetzt auch bei dir funktioniert.
Gruß
Franz
Sub Read_Control_Terminrange_to_Excel()
'by Ramses - extremely modified by fcs 2013-10.04
'Zeitraumabfrage über Startdatum = A1 und Enddatum = B1
'Verweis auf Outlook 11 Library im VB-Editor muss gesetzt sein
'Early Binding ab Outlook 2003 nicht möglich
'weil die Rückgabewerte der ITEM-Indexes zufällig ist und von der
'Installation abhängt !!
Dim myR As Integer, i As Integer
Dim startDate As Date, endDate As Date
Dim myOlApp As Object, myOlSpace As Object, myOlFolder As Object
Dim myOlAppointments As Object, myOlAppointment As Outlook.AppointmentItem
Dim TerminPlatz As Range
Dim RestrText As String
Dim bolEintragen As Boolean
'Termin Einträge
Set TerminPlatz = Sheets("Druck_Kalender").Range("A4")
myR = 0
'Löscht Terminbereich
TerminPlatz.Resize(12, 4).ClearContents
'Datum abfragen
With Sheets("Druck_Kalender").Range("B2")
startDate = .Value
endDate = .Value + 1
End With
'Datenbereich abfragen
RestrText = "([Start] >= '" & VBA.Format(startDate - 1, "ddddd") _
& "' AND [Start] = '" & VBA.Format(startDate, "ddddd") & "')"
'Debug.Print RestrText
'Deklaration
Set myOlApp = CreateObject("Outlook.Application")
Set myOlSpace = myOlApp.GetNamespace("MAPI")
Set myOlFolder = myOlSpace.GetDefaultFolder(olFolderCalendar)
Set myOlAppointments = myOlSpace.GetDefaultFolder(olFolderCalendar).Items
myOlAppointments.Sort "[Start]"
myOlAppointments.IncludeRecurrences = True
Set myOlAppointment = myOlAppointments.Find(RestrText)
While TypeName(myOlAppointment) "Nothing"
bolEintragen = False
With myOlAppointment
Select Case .AllDayEvent
Case True
'ganztägige Termine - Urlaub, Dienstreisen etc
If (.Start >= CDate(startDate) And .End = CDate(endDate)) Then
'Termindaten eintragen
TerminPlatz.Offset(myR, 0) = "ganzer Tag"
bolEintragen = True
End If
Case False
'Termine mit Zeitangaben
If (.Start >= CDate(startDate) And .End Format(.End, "DD.MM.YYYY") Then
If Day(.Start) = Day(startDate) And Day(.End) = Day(endDate) Or _
Day(.Start) = Day(startDate - 1) And Day(.End) = Day(startDate) Then
'Termin mit Beginn vor und Ende nach Mitternacht
If Day(startDate) = Day(.Start) Then
TerminPlatz.Offset(myR, 0) = _
Format(.Start, "hh:mm") & " - " & Format(.End, "hh:mm")
Else
TerminPlatz.Offset(myR, 0) = _
"*00:00 - " & Format(.End, "hh:mm")
End If
bolEintragen = True
ElseIf (CDate(Format(.Start, "YYYY-MM-DD")) = startDate) Then
'Termin über mehrere Tage mit Start und Ende Zeit
If startDate = CDate(Format(.Start, "YYYY-MM-DD")) Then
'Starttag
TerminPlatz.Offset(myR, 0) = _
Format(.Start, "hh:mm") & " - 00:00*"
ElseIf startDate = CDate(Format(.End, "YYYY-MM-DD")) Then
'Endetag
TerminPlatz.Offset(myR, 0) = _
"*00:00 - " & Format(.End, "hh:mm")
Else
TerminPlatz.Offset(myR, 0) = "mehrtägig"
End If
bolEintragen = True
End If
End If
End Select
If bolEintragen = True Then
TerminPlatz.Offset(myR, 1) = .Subject
myR = myR + 1
If myR > 12 Then MsgBox "zu viele Termine - Format wird unschön"
End If
End With
Set myOlAppointment = myOlAppointments.FindNext
Wend
'Variablen leeren
Set myOlApp = Nothing
Set myOlSpace = Nothing
Set myOlFolder = Nothing
Set myOlAppointments = Nothing
Set myOlAppointment = Nothing
MsgBox "Alle Termine im Zeitraum vom " & Format(startDate, "DD.MM.YYYY hh:mm") _
& " bis " & Format(endDate - TimeSerial(0, 1, 0), "DD.MM.YYYY hh:mm") & " eingelesen!"
End Sub