Sekretariate und Chefs die eigene Kalendereinträge erstellen/verändern

Microsoft Outlook bietet nützliche Funktionen um eine Vertretung oder ein Sekretariat zu unterstützen.

Eine wichtige Funktion gibt es allerdings nicht, nämlich eine Information, wenn der Eigentümer eines Kalenders selber Einträge hinzufügt, ändert oder löscht.
Diese Informationen gehen komplett am Sekretariat vorbei und müssten manuell kommuniziert werden, da wir aber die Welt kennen, geht sowas natürlich häufig unter und das Terminchaos ist vorprogrammiert...

Damit das nicht passiert, habe ich eine Outlook VBA Erweiterung geschrieben, welche diese Funktionen nachrüstet.

Achtung, da ich eig. kein VBA-Entwickler bin, kann der Code wahrscheinlich noch besser sein, aber für den Anwendungsfall reicht es wohl..

Unterstützte Funktionen:

• Hinzufügen eines Eintrags
• Ändern eines Eintrags
• Löschen eines Eintrags
• Separate Anzeige für Ganztägige Termine
• Übersetzbar
• Automatisches Ausblenden des Betreff,Inhalt und Ort bei "Privat" Markierung

Beispiel:

E-Mail Subject: Hinzugefügt: Kalendereintrag "Ein neuer Termin" von Skibbe, Oliver

E-Mail Inhalt:
Hinzugefügt: Kalendereintrag "Ein neuer Termin" von Skibbe, Oliver
Start: 10:30 am Mittwoch, 10. Juli 2013
Ende: 13:00 am Mittwoch, 10. Juli 2013
Status: Beschäftigt
Ort: Hannover
Inhalt: Besprechung mit XY zum Thema Z

Und hier der Code:

Option Explicit

'   This program is free software: you can redistribute it and/or modify
'   it under the terms of the GNU General Public License as published by
'   the Free Software Foundation, either version 3 of the License, or
'   (at your option) any later version.
'
'   This program is distributed in the hope that it will be useful,
'   but WITHOUT ANY WARRANTY; without even the implied warranty of
'   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
'   GNU General Public License for more details.
'
'   You should have received a copy of the GNU General Public License
'   along with this program.  If not, see <http://www.gnu.org/licenses/.
'
'   Dieses Programm ist Freie Software: Sie können es unter den Bedingungen
'   der GNU General Public License, wie von der Free Software Foundation,
'   Version 3 der Lizenz oder (nach Ihrer Option) jeder späteren
'   veröffentlichten Version, weiterverbreiten und/oder modifizieren.
'
'   Dieses Programm wird in der Hoffnung, dass es nützlich sein wird, aber
'   OHNE JEDE GEWÄHRLEISTUNG, bereitgestellt; sogar ohne die implizite
'   Gewährleistung der MARKTFÄHIGKEIT oder EIGNUNG FÜR EINEN BESTIMMTEN ZWECK.
'   Siehe die GNU General Public License für weitere Details.
'
'   Sie sollten eine Kopie der GNU General Public License zusammen mit diesem
'   Programm erhalten haben. Wenn nicht, siehe <http://www.gnu.org/licenses/
' 
'   Author: Oliver Skibbe ( oliskibbe at gmail.com )
'   Date: 2013-07-09
'   Purpose: Send mail to a configurable person if an calendar event is created, modified or deleted
'   Tested with: Outlook 2007
'   Hints:
'       http://www.vbarchiv.net/commands/details.php?id=formatdatetime
'       http://msdn.microsoft.com/en-us/library/office/bb208262%28v=office.12%29.aspx
'   Changelog:
'       2013-07-01 Oliver Skibbe: first release
'       2013-07-02 Oliver Skibbe: added check if private item (clear text if it is), added busy state to Output
'       2013-07-02 Oliver Skibbe: added allday check


Private WithEvents Items As Outlook.Items
Private WithEvents Reminders As Outlook.Reminders
Private WithEvents objCalFolder As Outlook.folder
Dim objDelFolder As Outlook.folder

' Helper variables
Public isDeletedBool As Boolean
Public reminderOccuredBool As Boolean

' Mail stuff
Public receiverStrg As String
Public subjectStrg As String
Public subjectPartStrg As String
Public bodyStrg As String

' Appointment helper strings
Public apptOrganizerStrg As String
Public apptLocationStrg As String
Public apptStartDateStrg As String
Public apptEndDateStrg As String
Public apptSubjectStrg As String
Public apptBodyStrg As String
Public apptBusyStateStrg As String
Public apptSensitivityStrg As String

' Translation
Public transAllDayEventStrg As String
Public transPrivateItemStrg As String
Public transAtStrg As String
Public transOfStrg As String
Public transAddedStrg As String
Public transChangedStrg As String
Public transDeletedStrg As String
Public transAvailStateStrg As String
Public transTentStateStrg As String
Public transBusyStateStrg As String
Public transOOOStateStrg As String
Public transCalendarStrg As String
Public transBodyStrg As String
Public transStateStrg As String
Public transLocationStrg As String
Public transStartStrg As String
Public transEndStrg As String

' subs
Private Sub Application_Startup()

  ' Receiver
  receiverStrg = "change.me@example.org"
  
  ' translation...modify if needed
  transAllDayEventStrg = "Ganztägig"
  transPrivateItemStrg = "Privater Termin"
  transAtStrg = "am"
  transOfStrg = "von"
  transAddedStrg = "Hinzugefügt"
  transChangedStrg = "Geändert"
  transDeletedStrg = "Gelöscht"
  transAvailStateStrg = "Verfügbar"
  transTentStateStrg = "Mit Vorbehalt"
  transBusyStateStrg = "Beschäftigt"
  transOOOStateStrg = "Abwesend"
  transCalendarStrg = "Kalendereintrag"
  transBodyStrg = "Inhalt"
  transStateStrg = "Status"
  transLocationStrg = "Ort"
  transStartStrg = "Start"
  transEndStrg = "Ende"
  
  Dim Ns As Outlook.NameSpace
  Dim CalFolder As Outlook.MAPIFolder
  Set Reminders = Outlook.Application.Reminders
  
  ' default values ..
  isDeletedBool = False
  reminderOccuredBool = False
    
  Set Ns = Application.GetNamespace("MAPI")
  Set CalFolder = Ns.GetDefaultFolder(olFolderCalendar)
  ' Set Folder = CalFolder.Folders("Subfolder")
  Set Items = CalFolder.Items
  
  Set objCalFolder = Application.Session.GetDefaultFolder(olFolderCalendar)
  Set objDelFolder = Application.Session.GetDefaultFolder(olFolderDeletedItems)
  
End Sub

' item add event
Private Sub Items_ItemAdd(ByVal Item As Object)
    ' Objects
    Dim Appt As Outlook.AppointmentItem
    
    ' if meeting or appointment..
    If TypeOf Item Is Outlook.AppointmentItem Or TypeOf Item Is Outlook.MeetingItem Then
        ' Appointment properties
        Set Appt = Item
        ' mail strings
        apptOrganizerStrg = Appt.Organizer
        ' AllDayEvent
        If Appt.AllDayEvent = True Then
            apptStartDateStrg = transAllDayEventStrg + ", " + FormatDateTime(Appt.Start, 1)
            ' we have to subtract one day to get a nice looking result
            apptEndDateStrg = transAllDayEventStrg + ", " + FormatDateTime(DateAdd("d", -1, Appt.End), 1)
        Else
            apptStartDateStrg = FormatDateTime(Appt.Start, 4) + " " + transAtStrg + " " + FormatDateTime(Appt.Start, 1)
            apptEndDateStrg = FormatDateTime(Appt.End, 4) + " " + transAtStrg + " " + FormatDateTime(Appt.End, 1)
        End If
        apptLocationStrg = Appt.Location
        apptBusyStateStrg = format(Appt.BusyStatus)
        apptSensitivityStrg = format(Appt.Sensitivity)
        apptBodyStrg = Appt.Body
        apptSubjectStrg = Appt.Subject
        subjectPartStrg = transAddedStrg
        
        ' send mail
        Call sendMail
    End If
End Sub

' busy state mapping
'   olBusy          2   The user is busy.
'   olFree          0   The user is available.
'   olOutOfOffice   3   The user is out of office.
'   olTentative     1   The user has a tentative appointment scheduled.
Private Sub busyState()
    Select Case apptBusyStateStrg
        Case Is = 0
            apptBusyStateStrg = transAvailStateStrg
        Case Is = 1
            apptBusyStateStrg = transTentStateStrg
        Case Is = 2
            apptBusyStateStrg = transBusyStateStrg
        Case Is = 3
            apptBusyStateStrg = transOOOStateStrg
        End Select
End Sub

' check if an calendar item is about to be deleted
Private Sub objCalFolder_BeforeItemMove(ByVal Item As Object, ByVal MoveTo As MAPIFolder, Cancel As Boolean)

    ' Objects
    Dim Appt As Outlook.AppointmentItem

    ' if meeting or appointment..
    If TypeOf Item Is Outlook.AppointmentItem Or TypeOf Item Is Outlook.MeetingItem Then
        ' Appointment properties
        Set Appt = Item
        
        ' saving calendar values for later purposes
        apptOrganizerStrg = Appt.Organizer
        ' AllDayEvent
        If Appt.AllDayEvent = True Then
            apptStartDateStrg = transAllDayEventStrg + ", " + FormatDateTime(Appt.Start, 1)
            ' we have to subtract one day to get a nice looking result
            apptEndDateStrg = transAllDayEventStrg + ", " + FormatDateTime(DateAdd("d", -1, Appt.End), 1)
        Else
            apptStartDateStrg = FormatDateTime(Appt.Start, 4) + " " + transAtStrg + " " + FormatDateTime(Appt.Start, 1)
            apptEndDateStrg = FormatDateTime(Appt.End, 4) + " " + transAtStrg + " " + FormatDateTime(Appt.End, 1)
        End If
        apptLocationStrg = Appt.Location
        apptBusyStateStrg = format(Appt.BusyStatus)
        apptSensitivityStrg = format(Appt.Sensitivity)
        apptBodyStrg = Appt.Body
        apptSubjectStrg = Appt.Subject
    End If
    
    ' check if item is deleted
    If MoveTo Is Nothing Then
        isDeletedBool = True
        Call Items_ItemChange(Item)
    ElseIf MoveTo = objDelFolder Then
        isDeletedBool = True
        Call Items_ItemChange(Item)
    End If
End Sub

Private Sub Items_ItemChange(ByVal Item As Object)
   
    ' Objects
    Dim Appt As Outlook.AppointmentItem
    
    ' if meeting or appointment..
    If TypeOf Item Is Outlook.AppointmentItem Or TypeOf Item Is Outlook.MeetingItem Then
    
        ' leave sub if just a reminder occured ( is set by: Sub Reminders_BeforeReminderShow )
        If reminderOccuredBool = True Then
            Exit Sub
        End If

        Set Appt = Item
        
        ' is set by Sub objCalFolder_BeforeItemMove
        If isDeletedBool = False Then
            apptOrganizerStrg = Appt.Organizer
            ' AllDayEvent
            If Appt.AllDayEvent = True Then
                apptStartDateStrg = transAllDayEventStrg + ", " + FormatDateTime(Appt.Start, 1)
                ' we have to subtract one day to get a nice looking result
                apptEndDateStrg = transAllDayEventStrg + ", " + FormatDateTime(DateAdd("d", -1, Appt.End), 1)
            Else
                apptStartDateStrg = FormatDateTime(Appt.Start, 4) + " " + transAtStrg + " " + FormatDateTime(Appt.Start, 1)
                apptEndDateStrg = FormatDateTime(Appt.End, 4) + " " + transAtStrg + " " + FormatDateTime(Appt.End, 1)
            End If
            apptLocationStrg = Appt.Location
            apptSensitivityStrg = format(Appt.Sensitivity)
            apptBusyStateStrg = format(Appt.BusyStatus)
            apptBodyStrg = Appt.Body
            apptSubjectStrg = Appt.Subject
            subjectPartStrg = transChangedStrg
        Else
            ' part of subject
            subjectPartStrg = transDeletedStrg
        End If
  
        ' send mail
        Call sendMail
    End If
End Sub

' Before reminder is shown, set variable to surpress ItemChange
Private Sub Reminders_BeforeReminderShow(Cancel As Boolean)
    reminderOccuredBool = True
End Sub

' finally prepare and send mail
'       olConfidential  3   Confidential
'       olNormal        0   Normal sensitivity
'       olPersonal      1   Personal
'       olPrivate       2   Private
Private Sub sendMail()
    
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    ' default values for body and location string
    If LenB(apptBodyStrg) = 0 Or apptSensitivityStrg > 0 Then
        apptBodyStrg = "-"
    End If
    If LenB(apptLocationStrg) = 0 Or apptSensitivityStrg > 0 Then
        apptLocationStrg = "-"
    End If
    If LenB(apptSubjectStrg) = 0 Or apptSensitivityStrg > 0 Then
        apptSubjectStrg = "-"
    End If
    If apptSensitivityStrg > 0 Then
        subjectPartStrg = transPrivateItemStrg + ": " + subjectPartStrg
    End If
    
    ' busy State string mapping
    Call busyState
    
    ' Subject
    subjectStrg = subjectPartStrg + ": " + transCalendarStrg + " " + Chr(34) + apptSubjectStrg + Chr(34) + " " + transOfStrg + " " + apptOrganizerStrg
    ' Body
    bodyStrg = subjectPartStrg + ": " + transCalendarStrg + " " + Chr(34) + apptSubjectStrg + Chr(34) + " " + transOfStrg + " " + apptOrganizerStrg + vbCrLf _
                    + vbCrLf _
                    + transStartStrg + ": " + apptStartDateStrg + vbCrLf _
                    + transEndStrg + ": " + apptEndDateStrg + vbCrLf _
                    + transStateStrg + ": " + apptBusyStateStrg + vbCrLf _
                    + transLocationStrg + ": " + apptLocationStrg + vbCrLf _
                    + vbCrLf _
                    + transBodyStrg + ": " + apptBodyStrg
                    
    With OutMail
        .To = receiverStrg
        .Subject = subjectStrg
        .Body = bodyStrg
        .Display
        .Send
    End With
End Sub

Der Code muss in den Visual-Basic Editor (Alt+F11) unter: Projekt1 -> Microsoft Office Outlook -> ThisOutlookSession beim Kalendereigentümer eingebunden werden.

Ich hoffe es hilft einigen Leuten, gerade der Part mit gelöschten Mails war etwas knifflig.



Bei Fragen zu dem Code kontaktiert mich bitte