Programm, welches Outlook Termine auf dem Desktop einblendet

Option Explicit


Type Termin
User As String
Betreff As String
Ort As String
Beginn As Date
Ende As Date
Dauer As Long
ZeitspanneZeigen As String
Vertraulichkeit As String 
Text As String


End Type
Dim aTermin() As Termin
Dim lngTermin As Long


Dim objOl As Object
Dim objCal As Object
Dim objItem As Object
Dim objApp As Object
Dim objRec As Object


Sub Terminauflistung()
Dim L As Long
lngTermin = 0
Erase aTermin
ReDim Preserve aTermin(lngTermin)


Set objOl = CreateObject("Outlook.Application")


GetAllAppointments "XP LOGINNAME" ''meistens vorname.name
''wenn weitere kalender freigegeben sind:
'GetAllAppointments "XP LOGINNAME2" ''meistens vorname.name des anderen nutzers
'GetAllAppointments "XP LOGINNAME3" ''meistens vorname.name des anderen nutzers




Set objOl = Nothing


Ausgabe:
'Application.ScreenUpdating = False
' davon ausgehend, dass 1. Zeile bereits Überschriften enthält


Application.ScreenUpdating = True
Rows("2:65536").Select
Selection.Delete Shift:=xlUp
For L = LBound(aTermin) To UBound(aTermin)




Dim AlterTermin As Date
AlterTermin = Left(aTermin(L).Beginn, 10)
If AlterTermin < Date Then GoTo blubb
If AlterTermin > Date + 30 Then GoTo blubb


'jetzt ggf. noch Filter
'Cells(L + 2, 1) = aTermin(L).User
'Cells(L + 2, 2) = aTermin(L).Betreff
'Cells(L + 2, 3) = aTermin(L).Ort
'Cells(L + 2, 4) = aTermin(L).Beginn
'Cells(L + 2, 5) = aTermin(L).Ende
'Cells(L + 2, 6) = aTermin(L).Dauer
'Cells(L + 2, 7) = aTermin(L).ZeitspanneZeigen
'Cells(L + 2, 8) = aTermin(L).Vertraulichkeit
'Cells(L + 2, 9) = aTermin(L).Text


Cells(L + 2, 1) = aTermin(L).User
Cells(L + 2, 2) = aTermin(L).Betreff
Cells(L + 2, 3) = aTermin(L).Ort


Dim FormelDatum
FormelDatum = Mid(aTermin(L).Beginn, 4, 2) & "/" & Left(aTermin(L).Beginn, 2) & "/" & Mid(aTermin(L).Beginn, 7, 4)
Cells(L + 2, 4).FormulaR1C1 = FormelDatum


Dim a As String
a = aTermin(L).Beginn
If Len(a) > 10 Then
    Cells(L + 2, 5) = Right(aTermin(L).Beginn, 8)
Else
    Cells(L + 2, 5) = " "
End If


Cells(L + 2, 6) = Left(aTermin(L).Ende, 10)
a = aTermin(L).Ende
If Len(a) > 10 Then
    Cells(L + 2, 7) = Right(aTermin(L).Ende, 8)
Else
    Cells(L + 2, 7) = " "
End If




Cells(L + 2, 8) = aTermin(L).Dauer
Cells(L + 2, 9) = aTermin(L).ZeitspanneZeigen
Cells(L + 2, 10) = aTermin(L).Vertraulichkeit
Cells(L + 2, 11) = aTermin(L).Text






blubb:
Next L


Range("a1").Value = "Name"
Range("b1").Value = "Betreff"
Range("c1").Value = "Ort"
Range("d1").Value = "Start"
Range("e1").Value = "StartZeit"
Range("f1").Value = "Ende"
Range("g1").Value = "EndeZeit"
Range("h1").Value = "Minuten"
Range("i1").Value = "Status"
Range("j1").Value = "Prio"


Range("a2").Select
Dim intAnzahl, i
ActiveCell.SpecialCells(xlLastCell).Select
intAnzahl = ActiveCell.Row
Range("a2").Select


        For i = 1 To intAnzahl
        If ActiveCell = "" Then
        Selection.EntireRow.Delete
        Else
        ActiveCell.Offset(1, 0).Select
        End If
        Next i


Cells.Select
Selection.Columns.AutoFit




Range("A1").Select
    Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Key2:=Range("E2") _
        , Order2:=xlAscending, Key3:=Range("A2"), Order3:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom


Application.ScreenUpdating = True
End Sub


Private Sub GetAllAppointments(strUser As String)
On Error Resume Next
Set objRec = objOl.Session.CreateRecipient(strUser)
objRec.Resolve
Set objCal = Nothing
Set objCal = objOl.Session.GetSharedDefaultFolder(objRec, 9)
If objCal Is Nothing Then Exit Sub
For Each objItem In objCal.Items
If TypeName(objItem) = "AppointmentItem" Then
Set objApp = objItem
' ggf. noch Dinge wie Feiertage, privat etc. ausschliessen
If Not InStr(1, objApp.Categories, "Feiertag") > 0 Then
ReDim Preserve aTermin(lngTermin)
With objApp
aTermin(lngTermin).User = strUser
aTermin(lngTermin).Betreff = .Subject
aTermin(lngTermin).Ort = .Location
aTermin(lngTermin).Beginn = .Start
aTermin(lngTermin).Ende = .End
aTermin(lngTermin).Dauer = .Duration
aTermin(lngTermin).ZeitspanneZeigen = fsgetFreeBusy(.BusyStatus)
aTermin(lngTermin).Vertraulichkeit = fsgetSensitivity(.Sensitivity)
'aTermin(lngTermin).Text = .Body ' falls Bedarf => ggf. Replace von vbcrlf
End With
lngTermin = lngTermin + 1
End If
End If
Next objItem
End Sub


Private Function fsgetFreeBusy(lngFreeBusy As Long) As String
Select Case lngFreeBusy
Case 0: fsgetFreeBusy = "Frei"
Case 1: fsgetFreeBusy = "Mit Vorbehalt"
Case 2: fsgetFreeBusy = "Gebucht"
Case 3: fsgetFreeBusy = "Abwesend"
End Select
End Function


Private Function fsgetSensitivity(lngSensitivity As Long) As String
Select Case lngSensitivity
Case 0: fsgetSensitivity = "Normal"
Case 1: fsgetSensitivity = "Persönlich"
Case 2: fsgetSensitivity = "Privat"
Case 3: fsgetSensitivity = "Vertraulich"
End Select
End Function