title image


Smiley Re: Outlook--> Excel: * Termine übersichtlich in Excel darstellen*
Hallo



Nicht erschrecken :-)

Aber da sind einige Knacknüsse mit TerminSerien zu bewältigen die Outlook auf eine ganze spezielle Art :-(( verwaltet.







'Code zusammenhängend definieren



Option Explicit

Sub Kalenderdaten_auf_Terminbereich_einlesen()

'(C) Ramses

'Zunächst Verweis auf OL-Bibliothek erstellen

'Early Binding ab Outlook 2003 nicht möglich

'weil die Rückgabewerte der ITEM-Indexes zufällig ist und von der

'Installation abhängt !!

'-------------

'Version Office 2000 (nicht getestet sollte aber tun)

'Dim olApp As Outlook.Application

'Dim Termin As Outlook.AppointmentItem

'Dim myTerminPatt As Outlook.RecurrencePattern

'-------------

'Set olApp = New outlook.Application

'Set Termin = olApp.CreateItem(olAppointmentItem)

'-------------

'Version XP

Dim olApp As Object

Dim Termin As Object

Set olApp = CreateObject("Outlook.Application")

'Allgemein gültig

Dim i As Long, j As Long, myErr As Integer

Dim startInput As String, startDate As Date

Dim endInput As String, endDate As Date

Dim myTerminPatt As Object

On Error GoTo myErrorHandler

'Erst mal alles löschen

Cells.ClearContents

Cells.Interior.ColorIndex = xlNone

'Startdatum abfragen

startInput = InputBox("Bitte Datum eingeben im Format ""01.01.2004""", "Datum für Terminsuche", Format(Now, "dd.mm.yyyy"))

myErr = 1

If startInput = "" Then

    MsgBox "Abbruch des Makros durch Benutzer"

    Exit Sub

ElseIf Not IsDate(DateValue(startInput)) Then

    MsgBox "Falsches Datum eingegeben"

    Exit Sub

End If

myErr = 2

endInput = InputBox("Bitte Datum eingeben im Format ""01.01.2004""", "Datum für Terminsuche", Format(DateValue(startInput) + 7, "dd.mm.yyyy"))

If endInput = "" Then

    MsgBox "Abbruch des Makros durch Benutzer"

    Exit Sub

ElseIf Not IsDate(DateValue(endInput)) Then

    MsgBox "Falsches Datum eingegeben"

    Exit Sub

End If

myErr = 0

'Variable definitiv zuweisen

startDate = DateValue(startInput)

endDate = DateValue(endInput)

'Variable fü¨r Termin neu setzen

'Set Termin = olApp.CreateItem(Appointment)

Cells(1, 1) = "Termine vom " & Format(startDate, "dd.mm.yyyy") & " bis " & Format(endDate, "dd.mm.yyyy")

i = 3

Application.ScreenUpdating = False

Cells(i, 1) = "Termin 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



'Durchlaufe alle Termine des aktuellen Standardkalenders

i = i + 1

For Each Termin In olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Items

    Set myTerminPatt = Termin.GetRecurrencePattern

    If Format(Termin.start, "dd.mm.yyyy") >= startDate And Format(Termin.End, "dd.mm.yyyy") <= endDate Then

        If Not Termin.AllDayEvent Then Trag_ein Termin, i, False

    End If

    If myTerminPatt.RecurrenceType = olRecursDaily Then

        If Format(myTerminPatt.PatternEndDate, "dd.mm.yyyy") >= startDate Then

                Trag_ein_Recurr Termin, i, False, startDate, endDate

        End If

    End If

Next

Range("C1").Select

Range("A1:H" & Range("A1").CurrentRegion.Rows.count).Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess



'Jetzt die Ereignisse

i = i + 1

j = i

Cells(i, 1) = "Ganzer Tag 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

    Debug.Print Termin.start

    If DateSerial(Year(startDate), Month(Termin.start), Day(Termin.start)) >= startDate And DateSerial(Year(startDate), Month(Termin.start), Day(Termin.start)) <= endDate Then

        If Termin.AllDayEvent And Not Termin.IsRecurring Then Trag_ein Termin, i, True

    End If

Next

Range("C" & j).Select

Range("A1:F" & Range("A" & j).CurrentRegion.Rows.count).Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess

'und noch die jährlichen Ereignisse

i = i + 2

j = i

Cells(i, 1) = "Betreff ""Jährliches Ereignis"""

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 DateSerial(Year(startDate), Month(Termin.start), Day(Termin.start)) >= startDate And DateSerial(Year(startDate), Month(Termin.start), Day(Termin.start)) <= endDate Then

        If Termin.AllDayEvent And Termin.IsRecurring Then Trag_ein Termin, i, True

    End If

Next

Range("C" & j).Select

Range("A1:F" & Range("A" & j).CurrentRegion.Rows.count).Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess

'Variablen leeren

Set Termin = Nothing

Set olApp = Nothing

Columns("A:H").Select

Columns("A:H").EntireColumn.AutoFit

Range("A1").Select

Cells.RowHeight = "12.75"



'Ausstieg

ErrorExit:

Application.ScreenUpdating = True

If myErr = 0 And Err.Number = 0 Then

    MsgBox "Kalenderdaten eingelesen"

End If

Exit Sub



myErrorHandler:

    Select Case myErr

        Case 1

            MsgBox "Ungültiges Startdatum"

            Resume ErrorExit

        Case 2

            MsgBox "Ungültiges Enddatum"

            Resume ErrorExit

    End Select

    MsgBox Err.Number & " " & Err.Description

    Resume ErrorExit

End Sub





Sub Trag_ein(Termin, i As Long, Ereignis As Boolean)

Dim Anzeigen_als As String

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



Sub Trag_ein_Recurr(Termin, i As Long, Ereignis As Boolean, startDate As Date, endDate As Date)

Dim Anzeigen_als As String

Dim Erinnerung As String

Dim n As Integer

Dim myReccTermin As Object

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

Set myReccTermin = Termin.GetRecurrencePattern

If startDate = endDate Then

    Cells(i, 1) = Termin.Subject

    Cells(i, 3) = startDate + (i - 1)

    Cells(i, 3).NumberFormat = "dd/mm/yyyy hh:mm"

    Cells(i, 4) = startDate + (i - 1)

    Cells(i, 4).Interior.ColorIndex = 3

    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

    i = i + 1

    Set myReccTermin = Nothing

    Exit Sub

End If

If myReccTermin.PatternEndDate < endDate Then

    Debug.Print myReccTermin.PatternEndDate

    If myReccTermin.PatternStartDate > startDate Then

        For n = 1 To endDate - myReccTermin.PatternEndDate '(myReccTermin.PatternStartDate - startDate)

            Cells(i, 1) = Termin.Subject

            Cells(i, 3) = myReccTermin.PatternStartDate + n

            Cells(i, 3).Interior.ColorIndex = 3

            Cells(i, 3).NumberFormat = "dd/mm/yyyy hh:mm"

            Cells(i, 4) = myReccTermin.PatternStartDate + n

            Cells(i, 4).Interior.ColorIndex = 3

            Cells(i, 4).NumberFormat = "dd/mm/yyyy hh:mm"

            Cells(i, 5) = Termin.ReminderMinutesBeforeStart

            Cells(i, 6) = Anzeigen_als

            Select Case myReccTermin.RecurrenceType

                Case 1

                    Cells(i, 7) = "Täglich"

                Case 2, 3

                    Cells(i, 7) = "Monatlich"

                Case 4

                    Cells(i, 7) = "Wöchentlich"

                Case 5, 6

                    Cells(i, 7) = "Jährlich"

                Case Else

                    Cells(i, 7) = "Serie"

            End Select

            Cells(i, 8) = Termin.CreationTime

            i = i + 1

        Next n

    Else

        For n = 1 To myReccTermin.PatternEndDate - startDate

            Cells(i, 1) = Termin.Subject

            Cells(i, 3) = startDate + n

            Cells(i, 3).NumberFormat = "dd/mm/yyyy hh:mm"

            Cells(i, 4) = startDate + n

            Cells(i, 4).Interior.ColorIndex = 3

            Cells(i, 4).NumberFormat = "dd/mm/yyyy hh:mm"

            Cells(i, 5) = Termin.ReminderMinutesBeforeStart

            Cells(i, 6) = Anzeigen_als

            Select Case myReccTermin.RecurrenceType

                Case 1

                    Cells(i, 7) = "Täglich"

                Case 2, 3

                    Cells(i, 7) = "Monatlich"

                Case 4

                    Cells(i, 7) = "Wöchentlich"

                Case 5, 6

                    Cells(i, 7) = "Jährlich"

                Case Else

                    Cells(i, 7) = "Serie"

            End Select

            Cells(i, 8) = Termin.CreationTime

            i = i + 1

        Next n

    End If

End If



If myReccTermin.PatternEndDate > endDate Then

    If myReccTermin.PatternStartDate > startDate Then

        For n = 1 To endDate - myReccTermin.PatternStartDate

            Cells(i, 1) = Termin.Subject

            Cells(i, 3) = myReccTermin.PatternStartDate + n

            Cells(i, 3).Interior.ColorIndex = 3

            Cells(i, 3).NumberFormat = "dd/mm/yyyy hh:mm"

            Cells(i, 4) = myReccTermin.PatternStartDate + n

            Cells(i, 4).Interior.ColorIndex = 3

            Cells(i, 4).NumberFormat = "dd/mm/yyyy hh:mm"

            Cells(i, 5) = Termin.ReminderMinutesBeforeStart

            Cells(i, 6) = Anzeigen_als

            Select Case myReccTermin.RecurrenceType

                Case 1

                    Cells(i, 7) = "Täglich"

                Case 2, 3

                    Cells(i, 7) = "Monatlich"

                Case 4

                    Cells(i, 7) = "Wöchentlich"

                Case 5, 6

                    Cells(i, 7) = "Jährlich"

                Case Else

                    Cells(i, 7) = "Serie"

            End Select

            Cells(i, 8) = Termin.CreationTime

            i = i + 1

        Next n

    Else

        For n = 1 To myReccTermin.PatternEndDate - startDate

            Cells(i, 1) = Termin.Subject

            Cells(i, 3) = startDate + n

            Cells(i, 3).Interior.ColorIndex = 3

            Cells(i, 3).NumberFormat = "dd/mm/yyyy hh:mm"

            Cells(i, 4) = startDate + n

            Cells(i, 4).Interior.ColorIndex = 3

            Cells(i, 4).NumberFormat = "dd/mm/yyyy hh:mm"

            Cells(i, 5) = Termin.ReminderMinutesBeforeStart

            Cells(i, 6) = Anzeigen_als

            Select Case myReccTermin.RecurrenceType

                Case 1

                    Cells(i, 7) = "Täglich"

                Case 2, 3

                    Cells(i, 7) = "Monatlich"

                Case 4

                    Cells(i, 7) = "Wöchentlich"

                Case 5, 6

                    Cells(i, 7) = "Jährlich"

                Case Else

                    Cells(i, 7) = "Serie"

            End Select

            Cells(i, 8) = Termin.CreationTime

            i = i + 1

        Next n

    End If

End If

Set myReccTermin = Nothing

End Sub

'----------------------



Code eingefügt mit Syntaxhighlighter 2.5







Das ganze sieht dann in etwa so aus



Tabelle1 th {font-weight:normal}  ABCDEF1Termin BetreffInhalt/BodyStartEndeErinnerung MinutenAnzeigen als2Termine vom 01.05.2005 bis 30.05.2005     3      4PRÜFUNG SIZ Projektleiter 24.05.2005 08:0024.05.2005 17:001080Frei5      6Ganzer Tag BetreffEreignis amErinnerung MinutenAnzeigen alsKategorienErstellt am7Graz - Maribor18.05.2005 00:0018 StundenFrei 24.04.2005 18:148Feiertag Fronleichnam05.05.2005 00:0018 StundenFrei 24.04.2005 18:159      10      11Betreff "Jährliches Ereignis"jährliches Ereignis amErinnerung MinutenAnzeigen alsKategorienErstellt am12Heidi Geburtstag11.05.2000 00:002 TageFrei 07.12.2002 11:3013        Diagramm - Grafik - Excel Tabellen einfach im Web darstellen    Excel Jeanie HTML  3.0    Download  







Viel Spass beim einlesen und ausprobieren



Gruss Rainer
Herzliche Grüsse

aus der Schweiz

Rainer

Kombiniere Geist und Google,...denn Wissen ist geil :-)



geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: