Nun aber auch noch ... :-)
Ramses
Hallo
nun habe ewig rumgepfrimmelt bis ich das blöde restrict endlich auf der Reihe hatte,... nun will ich's auch noch zeigen :-)
Sub Read_Control_Termin_to_Excel()
'by Ramses
Dim myR As Integer, i As Integer
Dim startDate As Date, endDate As Date, recDate As Date
Dim myOlApp As Object, myOlSpace As Object, myOlFolder As Object
Dim myOlDateRange As Object, sAppoint As Object
'Datum vorschlagen
Select Case Weekday(Now + 1, vbMonday)
Case Is > 5
recDate = Now + 3
Case Else
recDate = Now + 1
End Select
'Datum abfragen
startDate = Format(DateValue(InputBox("Welches Datum soll abgefragt werden ?" & Chr$(13) & _
"Datum muss im Format ""01.01.2004"" eingeben werden", "Terminsuche", Format(recDate, "dd.mm.yyyy"))))
'Alternativ
'startDate = ActiveSheet.Range("A1") 'Zelle mit Startdatum
'endAte = ActiveSheet.Range("B1") 'Zelle mit Enddatum
'Deklaration
Set myOlApp = CreateObject("Outlook.Application")
Set myOlSpace = myOlApp.GetNamespace("MAPI")
Set myOlFolder = myOlSpace.GetDefaultFolder(olFolderCalendar)
Set myOlDateRange = myOlFolder.Items.Restrict("[Start] >= '" & startDate & "' and [end] <= & '" & startDate + 1 & "'")
'Alternative mit Start- und Enddatum
'Set myOlDateRange = myOlFolder.Items.Restrict("[Start] >= '" & startDate & "' and [end] <= & '" & endDate & "'")
'Suche beginnen
myR = 2
'Löscht alle zellen in der aktiven Tabelle
Cells.ClearContents
Cells(1, 1) = "Termin"
Cells(1, 2) = "Dauer"
Cells(1, 3) = "Ende"
Cells(1, 4) = "Ort"
Cells(1, 5) = "Betreff"
Cells(1, 6) = "Textinfo"
'Alternativ mit Start- und EndDatum in Zeile 1
'Range(Cells(myR, 1), Cells(Rows.Count, 5)).ClearContents
'Cells(myR, 1) = "Termin"
'Cells(myR, 2) = "Dauer"
'Cells(myR, 3) = "Ort"
'Cells(myR, 4) = "Betreff"
'Cells(myR, 5) = "Textinfo"
'myR = myR + 1
For Each sAppoint In myOlDateRange
With sAppoint
'Termindaten eintragen
Cells(myR, 1) = Format(.Start, "dd.mm.yyyy hh:mm")
Cells(myR, 2) = .duration
Cells(myR, 3) = Format(.Start + (((1 / 24) / 60) * .duration), "hh:mm")
Cells(myR, 4) = .Location
Cells(myR, 5) = .Subject
Cells(myR, 6) = .Body
'Cells(myR, 6) = .Start
myR = myR + 1
End With
Next
'Variablen leeren
Set myOlApp = Nothing
Set myOlSpace = Nothing
Set myOlFolder = Nothing
MsgBox "Alle Termine für den " & startDate & " eingelesen!"
'Alternativ mit Start- und EndDatum
'MsgBox "Alle Termine für den Zeitraum vom " & startDate & " bis " & endDate & " eingelesen!"
End Sub
Gruss Rainer
Auch wenn Sam schon gezeigt, kann ich es wenigstens für meine HP brauchen ;-)