AW: Outlook Wochenkalender importieren
21.11.2005 15:49:46
Frank
Hallo Jens,
anbei eine ausbaufähige Lösung:
Option Explicit
Sub sGetAllTermine()
Dim dStart As Date
Dim dEnde As Date
Dim objApp As Outlook.Application
Dim objKalender As MAPIFolder
Dim objAppts As Items
Dim objItem As AppointmentItem
Dim lngCount As Long
On Error GoTo PROC_Err
Set objApp = CreateObject("Outlook.Application")
Set objKalender = objApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
Set objAppts = objKalender.Items
If objAppts Is Nothing Then Exit Sub
If objAppts.Count = 0 Then Exit Sub
' Datum eingrenzen
dStart = InputBox("Bitte das Startdatum eingeben:", "Startdatum", Date)
dEnde = InputBox("Bitte das Enddatum eingeben:", "Enddatum ", Date)
Set objAppts = objAppts.Restrict("[Start] >= '#" & dStart & "#' AND [End] <= '#" & dEnde & "#'")
' Sortierung!
objAppts.Sort ["Start"], False
Set objItem = objAppts.GetFirst
Do While TypeName(objItem) <> "Nothing"
With objItem
Debug.Print .Subject, .Start, .End, .AllDayEvent
' Hier alle benötigen Felder auslesen und in die Tabelle einschreiben
End With
Set objItem = objAppts.GetNext
Loop
PROC_Exit:
On Error Resume Next
Set objAppts = Nothing
Set objKalender = Nothing
Set objApp = Nothing
Exit Sub
PROC_Err:
MsgBox Err.Description, vbCritical, "Fehler #" & Err.Number
Resume PROC_Exit
End Sub
Viel Spaß
Frank.