Neuer Termin mit Kontakt

Anwender von Outlook® 2007 vermissen unter anderem die Funktion Neuer Termin mit Kontakt, die in früheren Versionen noch enthalten war. Mit dem folgenden Codebeispiel lässt sich die Funktion jedoch wieder nachrüsten.

Zur Verwendung dieses Beispiels beachten Sie bitte die wichtigen Hinweise, sowie den Workshop VBA in Outlook® verwenden. Den Code bitte in ein neues Modul kopieren (Einfügen -> Modul im VBA-Editor).

Für Outlook® 2000, Outlook® 2002, Outlook® 2003, Outlook® 2007

Option Explicit
 
Public Sub NewAppointmentWithContact()
 
    '=====================================================================
    ' Bildet die Funktion "Neuer Termin mit Kontakt" für Benutzer von
    ' Outlook® 2007 nach.
    ' (c) Peter Marchert - http://www.outlook-stuff.com/
    ' 2008-11-21 Version 1.0.0
    ' 2008-11-23 Version 1.0.1
    '=====================================================================
 
    Dim objCalendar As Outlook.MAPIFolder           ' Standardkalender
    Dim objContact As Outlook.ContactItem           ' Kontakt
    Dim objAppointment As Outlook.AppointmentItem   ' Neuer Termin
 
    '---------------------------------------------------------------------
    ' Nachfolgende Konstanten mit "" vorbelegen, wenn nicht gewünscht
    '---------------------------------------------------------------------
    Const MYCATEGORIES As String = "Geschäftlich"  ' Kategorie (mehrere
                                                   ' durch ";" trennen)
    Const REMINDER As String = "30"            ' Erinnerung in min
    Const MYDURATION As String = "60"          ' Dauer in min
    Const PERSONAL As String = ""              ' "Wahr", wenn Privattermin
    Const SHOWDIALOG As String = "Wahr"        ' "Wahr", wenn Kategorie-
                                               ' auswahl angezeigt werden
                                               ' soll
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Aktuell geöffneten Kontakt refernzieren
    '---------------------------------------------------------------------
    Set objContact = Outlook.ActiveInspector.CurrentItem
 
    '---------------------------------------------------------------------
    ' Ist kein Kontakt geöffnet, wird der gerade markierte verwendet
    '---------------------------------------------------------------------
    If objContact Is Nothing Then Set objContact = Outlook.ActiveExplorer.Selection(1)
 
    '---------------------------------------------------------------------
    ' Auch kein Kontakt markiert?
    '---------------------------------------------------------------------
    If objContact Is Nothing Then
        MsgBox "Bitte markieren bzw. öffnen Sie einen Kontakt." _
            , vbCritical + vbOKOnly, "Neuer Termin mit Kontakt"
        Exit Sub
    End If
 
    '---------------------------------------------------------------------
    ' Standardkalender referenzieren
    '---------------------------------------------------------------------
    Set objCalendar = Outlook.Session.GetDefaultFolder(olFolderCalendar)
 
    '---------------------------------------------------------------------
    ' Neuen Termin erstellen
    '---------------------------------------------------------------------
    Set objAppointment = objCalendar.Items.Add
 
    '---------------------------------------------------------------------
    ' Termin mit Werten füllen
    '---------------------------------------------------------------------
    With objAppointment
 
        '-----------------------------------------------------------------
        ' Betreff festlegen
        '-----------------------------------------------------------------
        .Subject = "Termin mit " & objContact.Subject
 
        '-----------------------------------------------------------------
        ' Konstanten berücksichtigen
        '-----------------------------------------------------------------
        If MYCATEGORIES <> "" Then .Categories = MYCATEGORIES
        If REMINDER <> "" Then .ReminderMinutesBeforeStart = CLng(REMINDER)
        If MYDURATION <> "" Then .Duration = CLng(MYDURATION)
        If PERSONAL <> "" Then .Sensitivity = olPrivate
 
        '-----------------------------------------------------------------
        ' Kontakt als Link einfügen
        '-----------------------------------------------------------------
        Call .Links.Add(objContact)
 
        '-----------------------------------------------------------------
        ' Termin anzeigen
        '-----------------------------------------------------------------
        .Display
 
        '-----------------------------------------------------------------
        ' Dialog zur Kategorieauswahl anzeigen? (erst ab 2002)
        '-----------------------------------------------------------------
        If SHOWDIALOG <> "" Then .ShowCategoriesDialog
 
    End With
 
    '---------------------------------------------------------------------
    ' Referenzen löschen
    '---------------------------------------------------------------------
    Set objContact = Nothing
    Set objAppointment = Nothing
    Set objCalendar = Nothing
 
End Sub