Re: Outlook-Kalender importieren
29.01.2003 21:54:32
Bernd Held
Hallo Thomy,oj, ich habs hingekriegt:
Sub Kalenderdaten_einlesen()
Dim olApp As Outlook.Application
Dim Termin As Outlook.AppointmentItem
Dim i As Long, j As Long
Set olApp = New Outlook.Application
i = 1
Application.ScreenUpdating = False
Cells(i, 1) = "Betreff"
Cells(i, 2) = "Inhalt/Body"
Cells(i, 3) = "Start"
Cells(i, 4) = "Ende"
Cells(i, 5) = "Erinnerung Minuten"
Cells(i, 6) = "Anzeigen als"
Cells(i, 7) = "Kategorien"
Cells(i, 8) = "Erstellt am"
Range(Cells(i, 1), Cells(i, 8)).Select
Selection.Interior.ColorIndex = 15
i = i + 1
For Each Termin In olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Items
If Not Termin.AllDayEvent Then Trag_ein Termin, i, True
Next
Range("C1").Select
Range("A1:H" & Range("A1").CurrentRegion.Rows.Count).Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess
i = i + 1
j = i
Cells(i, 1) = "Betreff"
Cells(i, 2) = "Ereignis am"
Cells(i, 3) = "Erinnerung Minuten"
Cells(i, 4) = "Anzeigen als"
Cells(i, 5) = "Kategorien"
Cells(i, 6) = "Erstellt am"
Range(Cells(i, 1), Cells(i, 6)).Select
Selection.Interior.ColorIndex = 15
i = i + 1
For Each Termin In olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Items
If Termin.AllDayEvent And Not Termin.IsRecurring Then Trag_ein Termin, i, True
Next
Range("C" & j).Select
Range("A1:F" & Range("A" & j).CurrentRegion.Rows.Count).Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess
i = i + 1
j = i
Cells(i, 1) = "Betreff"
Cells(i, 2) = "jährliches Ereignis am"
Cells(i, 3) = "Erinnerung Minuten"
Cells(i, 4) = "Anzeigen als"
Cells(i, 5) = "Kategorien"
Cells(i, 6) = "Erstellt am"
Range(Cells(i, 1), Cells(i, 6)).Select
Selection.Interior.ColorIndex = 15
i = i + 1
For Each Termin In olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Items
If Termin.AllDayEvent And Termin.IsRecurring Then Trag_ein Termin, i, True
Next
Range("C" & j).Select
Range("A1:F" & Range("A" & j).CurrentRegion.Rows.Count).Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess
Set Termin = Nothing
Set olApp = Nothing
Columns("A:H").Select
Columns("A:H").EntireColumn.AutoFit
Range("A1").Select
Application.ScreenUpdating = True
End Sub
Sub Trag_ein(Termin As AppointmentItem, i As Long, Ereignis As Boolean)
Dim Anzeigen_als As String
Dim Spalte As Integer
Dim Erinnerung As String
Select Case Termin.BusyStatus
Case olFree
Anzeigen_als = "Frei"
Case olTentative
Anzeigen_als = "Unter Vorbehalt"
Case olBusy
Anzeigen_als = "Gebucht"
Case olOutOfOffice
Anzeigen_als = "Abwesend"
End Select
Cells(i, 1) = Termin.Subject
If Not Ereignis Then
Cells(i, 2) = Termin.Body
Cells(i, 3) = Termin.Start
Cells(i, 3).NumberFormat = "dd/mm/yyyy hh:mm"
Cells(i, 4) = Termin.End
Cells(i, 4).NumberFormat = "dd/mm/yyyy hh:mm"
Cells(i, 5) = Termin.ReminderMinutesBeforeStart
Cells(i, 6) = Anzeigen_als
Cells(i, 7) = Termin.Categories
Cells(i, 8) = Termin.CreationTime
Else
Cells(i, 2) = Termin.Start
Cells(i, 2).NumberFormat = "dd/mm/yyyy hh:mm"
If Termin.ReminderMinutesBeforeStart <= 60 Then
Erinnerung = Termin.ReminderMinutesBeforeStart & " Minuten"
ElseIf Termin.ReminderMinutesBeforeStart / 60 < 24 Then
Erinnerung = Termin.ReminderMinutesBeforeStart / 60 & " Stunden"
Else
Erinnerung = Termin.ReminderMinutesBeforeStart / 60 / 24 & " Tage"
End If
Cells(i, 3) = Erinnerung
Cells(i, 3).NumberFormat = "General"
Cells(i, 4) = Anzeigen_als
Cells(i, 5) = Termin.Categories
Cells(i, 6) = Termin.CreationTime
End If
i = i + 1
End Sub
Viele Grüße
Bernd
MVP für Microsoft Excel
Noch mehr Excel-Tipps und VBA-Datenbank unter: http://held-office.de