Option Explicit

Dim WithEvents objProjects As Outlook.Folders
Dim WithEvents objAppointments As Outlook.Items
Dim WithEvents objAppointmentFolder As Outlook.Folder
Dim colProjects As Collection

Dim WithEvents objAppointmentItems As Outlook.Items

Public Sub Application_Startup()
10        On Error GoTo Application_Startup_Err
          Dim objProject As Outlook.Folder
          Dim objTasks As clsTasks
          'Stellt objAppointments auf die im Calendar-Folder enthaltene Sammlung von Items ein
20        Set objAppointments = GetMAPINamespace.GetDefaultFolder(olFolderCalendar).Items
          'Prft, ob ein Folder namens Projekte vorhanden ist und legt diesen gegebenenfalls an
30        On Error Resume Next
40        Set objProject = GetTaskfolder.Folders("Projekte")
50        If Not Err.Number = 0 Then
60            GetTaskfolder.Folders.Add "Projekte", olFolderTasks
70        End If
80        On Error GoTo Application_Startup_Err
          'Stellt objProjects auf den Folder Projekte ein.
90        Set objProjects = GetTaskfolder.Folders("Projekte").Folders
          'Stellt objAppointmentFolder auf den Standardfolder Calendar ein
100       Set objAppointmentFolder = GetMAPINamespace.GetDefaultFolder(olFolderCalendar)
          'Erzeugt eine neue Collection
110       Set colProjects = New Collection
          'Durchluft alle Folder im Folder "Projekte" ...
120       For Each objProject In objProjects
              '... erzeugt fr jeden Eintrag ein neues Objekt der Klasse clsTasks ...
130           Set objTasks = New clsTasks
              '... weist diesem die enthaltenen Task-Items ...
140           Set objTasks.Tasks = objProject.Items
              '... und den Projekt-Folder selbst zu ...
150           Set objTasks.Project = objProject
              '... und fgt das neue Objekt der oben erzeugten Collection hinzu.
160           colProjects.Add objTasks
170       Next
Application_Startup_Exit:
180       On Error Resume Next
190       Exit Sub
Application_Startup_Err:
200       Call Fehlerbehandlung("Projekt1/ThisOutlookSession", "Application_Startup", Erl, "Bemerkungen: ./.")
210       GoTo Application_Startup_Exit
End Sub

'Das Objekt objAppointmentFolder ist der Ordner mit den Terminen, also den Ttigkeiten.
'Dessen BeforeItemMove-Methode wird immer ausgelst, wenn ein bestehendes Element in einen anderen Ordner verschoben wird,
'was praktisch nur passiert, wenn dieser in den Mlleimer verschoben oder anderweitig gelscht wird.
Private Sub objAppointmentFolder_BeforeItemMove(ByVal Item As Object, ByVal MoveTo As MAPIFolder, Cancel As Boolean)
          Dim lngActionID As Long
          Dim strAction As String
          Dim strSQL As String
          Dim objItem As Outlook.AppointmentItem
          'Nach einer Prfung, ob es sich um ein Objekt des Typs AppointmentItem handelt,
10        If TypeOf Item Is Outlook.AppointmentItem Then
              'wird dieses der Objektvariablen objItem zugewiesen.
20            Set objItem = Item
              'Der Betreff wird in strAction gespeichert ...
30            strAction = objItem.Subject
              '... und die ID aus der Eigenschaft BillingInformation ausgelesen.
40            lngActionID = GetID(objItem.BillingInformation, "action")
              'Soll der Eintrag gelscht werden, ist der Zielordner also "Gelschte Objekte", ...
50            If MoveTo.Name = "Gelschte Objekte" Then
                  '... wird der entsprechende Eintrag aktualisiert.
60                strSQL = "UPDATE tblTaetigkeiten SET GeloeschtAm = " & ISODatum(Now) & " WHERE TaetigkeitID = " & lngActionID
70                CurrentDBC.Execute strSQL
80            End If
90        End If
End Sub

'ItemAdd wird immer beim Neuanlegen eines Termins, also einer Ttigkeit, ausgelst.
Private Sub objAppointments_ItemAdd(ByVal Item As Object)
10        On Error GoTo objAppointments_ItemAdd_Err

          Dim objAppointment As Outlook.AppointmentItem
          Dim objTaskID As UserProperty
          Dim lngTaskID As Long
          Dim lngActionID As Long
          Dim strSQL As String
          'Nach der Prfung, ob es sich berhaupt um einen Termin handelt, ...
20        If TypeOf Item Is Outlook.AppointmentItem Then
30            Set objAppointment = Item
              '... ermittelt die Hilfsfunktion GetID aus dem BillingInformations die ID des Termins ...
40            lngTaskID = GetID(objAppointment.Body, "task")
              '... und die Routine prft, ob der Termin eine Ttigkeit ist, also auf Basis einer in einem der Projektordner angelegten Aufgabe ist.
50            If Not lngTaskID = 0 Then
                  'Falls ja, legen die folgenden zwei Zeilen einen neuen Eintrag an:
60                strSQL = "INSERT INTO tblTaetigkeiten(Taetigkeit, Startzeit, Endzeit, AufgabeID, Beschreibung) VALUES('" & objAppointment.Subject & "', " & ISODatum(objAppointment.Start) & ", " & ISODatum(objAppointment.End) & ", " & lngTaskID & ", '" & objAppointment.Body & "')"
70                CurrentDBC.Execute strSQL, dbFailOnError
                  'Die ID der Ttigkeit in der Datenbank wird ausgelesen ...
80                lngActionID = CurrentDBC.OpenRecordset("SELECT @@IDENTITY").Fields(0).Value
                  '... und im Erfolgsfall in geeigneter Form zur Eigenschaft BillingInformation hinzugefgt.
90                If CurrentDBC.RecordsAffected = 1 Then
100                   objAppointment.BillingInformation = "[action|" & lngActionID & "]"
110                   objAppointment.Save
120               End If
130           End If
140       End If

objAppointments_ItemAdd_Exit:
150       On Error Resume Next
160       Exit Sub
objAppointments_ItemAdd_Err:
170       Call Fehlerbehandlung("Projekt1/ThisOutlookSession", "objAppointments_ItemAdd", Erl, "Bemerkungen: ./.")
180       GoTo objAppointments_ItemAdd_Exit
End Sub

'ItemChange wird beim ndern eines Termins ausgelst.
Private Sub objAppointments_ItemChange(ByVal Item As Object)
10        On Error GoTo objAppointments_ItemChange_Err

          Dim objAppointment As Outlook.AppointmentItem
          Dim lngActionID As Long
          Dim strSQL As String
          'Obligatorische Prfung auf den Elementtyp
20        If TypeOf Item Is Outlook.AppointmentItem Then
30            Set objAppointment = Item
              'Ermitteln der ID
40            lngActionID = GetID(objAppointment.BillingInformation, "action")
              'Wenn ID vergeben ...
50            If Not lngActionID = 0 Then
                  '... Eintrag in Datenbank aktualisieren.
60                strSQL = "UPDATE tblTaetigkeiten SET Taetigkeit = '" & objAppointment.Subject & "', Startzeit = " & ISODatum(objAppointment.Start) & ", Endzeit = " & ISODatum(objAppointment.End) & ", Beschreibung = '" & objAppointment.Body & "' WHERE TaetigkeitID = " & lngActionID
70                CurrentDBC.Execute strSQL, dbFailOnError
80            End If
90        End If

objAppointments_ItemChange_Exit:
100       On Error Resume Next
110       Exit Sub
objAppointments_ItemChange_Err:
120       Call Fehlerbehandlung("Projekt1/ThisOutlookSession", "objAppointments_ItemChange", Erl, "Bemerkungen: ./.")
130       GoTo objAppointments_ItemChange_Exit
End Sub

'objProjects reprsentiert die Auflistung der Folder im Ordner "Projekte".
'FolderAdd wird beim Hinzufgen eines neuen Ordners zur Auflistung ausgelst.
'Der Parameter Folder bergibt eine Referenz auf den hinzugefgten Ordner.
Private Sub objProjects_FolderAdd(ByVal Folder As MAPIFolder)
10        On Error GoTo objProjects_FolderAdd_Err

          Dim strSQL As String
          Dim objTasks As clsTasks
          'Prfung auf den Typ
20        Select Case Folder.DefaultItemType
              'Wenn Aufgabenordner, dann ...
              Case olTaskItem
                  'Ordner in der Datenbank speichern ...
30                strSQL = "INSERT INTO tblProjekte(Projektbezeichnung) VALUES('" & Folder.Name & "')"
40                CurrentDBC.Execute strSQL, dbFailOnError
                  '... und im Erfolgsfall die ID auslesen und in die Description-Eigenschaft des Folder-Objekts schreiben.
50                If CurrentDBC.RecordsAffected = 1 Then
60                    Folder.Description = "[project|" & CurrentDBC.OpenRecordset("SELECT @@IDENTITY").Fields(0).Value & "]"
70                End If
80            Case Else
      '            MsgBox "andere Foldersorte, Add"
90        End Select
100       Set objTasks = New clsTasks
110       Set objTasks.Tasks = Folder.Items
120       Set objTasks.Project = Folder
130       colProjects.Add objTasks

objProjects_FolderAdd_Exit:
140       On Error Resume Next
150       Exit Sub
objProjects_FolderAdd_Err:
160       Call Fehlerbehandlung("Projekt1/ThisOutlookSession", "objProjects_FolderAdd", Erl, "Bemerkungen: ./.")
170       GoTo objProjects_FolderAdd_Exit
End Sub

'FolderChange wird beispielsweise beim Umbenennen eines Folders ausgelst.
Private Sub objProjects_FolderChange(ByVal Folder As MAPIFolder)
          Dim strDescription As String
          Dim lngProjectID As Long
          Dim strSQL As String
          
          'Prfung des Ordnertyps ...
10        Select Case Folder.DefaultItemType
              '... wenn Aufgabenordner, dann:
              Case olTaskItem
                  'Beschreibung auslesen und ...
20                strDescription = Folder.Description
                  'daraus die ID ermitteln
30                lngProjectID = GetID(strDescription, "project")
                  
                  'Wenn ID vorhanden, dann ...
40                If Not lngProjectID = 0 Then
                      '... bernehme nderung in die Datenbank
50                    strSQL = "UPDATE tblProjekte SET Projektbezeichnung = '" & Folder.Name & "' WHERE ProjektID = " & lngProjectID
60                    CurrentDBC.Execute strSQL, dbFailOnError
70                End If
80            Case Else
                  'MsgBox "andere Foldersorte, Change"
90        End Select
End Sub

