New Appointment with Contact

Users of Outlook® 2007 are missing the function New Appointment with Contact, which was still present in previous versions. With the help of the following code example you can rebuild this functionality.

To use this example please read the important notes and have a look to the workshop Use VBA in Outlook®. Please insert this code into a new module (Insert -> Module in the VBA-Editor).

For Outlook® 2000, Outlook® 2002, Outlook® 2003, Outlook® 2007

Option Explicit
 
Public Sub NewAppointmentWithContact()
 
    '=====================================================================
    ' Recreates the function "New Appointment with Contact" for users with
    ' Outlook® 2007.
    ' (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          ' Default calendar
    Dim objContact As Outlook.ContactItem          ' Contact
    Dim objAppointment As Outlook.AppointmentItem  ' New appointment
 
    '---------------------------------------------------------------------
    ' Set following constants to "" if you don't want to use them
    '---------------------------------------------------------------------
    Const MYCATEGORIES As String = "Business"  ' Categories (divide
                                               ' multiple by a ";")
    Const REMINDER As String = "30"            ' Reminder in min
    Const MYDURATION As String = "60"          ' Duration in min
    Const PERSONAL As String = ""              ' "True", if private
    Const SHOWDIALOG As String = "True"        ' "True", if categories
                                               ' dialog should be shown
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Reference the open contact
    '---------------------------------------------------------------------
    Set objContact = Outlook.ActiveInspector.CurrentItem
 
    '---------------------------------------------------------------------
    ' If no contact is open, reference the selected item
    '---------------------------------------------------------------------
    If objContact Is Nothing Then Set objContact = Outlook.ActiveExplorer.Selection(1)
 
    '---------------------------------------------------------------------
    ' Also no contact is selected?
    '---------------------------------------------------------------------
    If objContact Is Nothing Then
        MsgBox "Please mark and/or open a contact." _
            , vbCritical + vbOKOnly, "New Appointment with Contact"
        Exit Sub
    End If
 
    '---------------------------------------------------------------------
    ' Set reference to default calendar
    '---------------------------------------------------------------------
    Set objCalendar = Outlook.Session.GetDefaultFolder(olFolderCalendar)
 
    '---------------------------------------------------------------------
    ' Create new appointment
    '---------------------------------------------------------------------
    Set objAppointment = objCalendar.Items.Add
 
    '---------------------------------------------------------------------
    ' Fill appointment with values
    '---------------------------------------------------------------------
    With objAppointment
 
        '-----------------------------------------------------------------
        ' Set subject
        '-----------------------------------------------------------------
        .Subject = "Termin mit " & objContact.Subject
 
        '-----------------------------------------------------------------
        ' Use constants
        '-----------------------------------------------------------------
        If MYCATEGORIES <> "" Then .Categories = MYCATEGORIES
        If REMINDER <> "" Then .ReminderMinutesBeforeStart = CLng(REMINDER)
        If MYDURATION <> "" Then .Duration = CLng(MYDURATION)
        If PERSONAL <> "" Then .Sensitivity = olPrivate
 
        '-----------------------------------------------------------------
        ' Insert contact as link
        '-----------------------------------------------------------------
        Call .Links.Add(objContact)
 
        '-----------------------------------------------------------------
        ' Show appoinment
        '-----------------------------------------------------------------
        .Display
 
        '-----------------------------------------------------------------
        ' Show dialog to select categories? (2002 or higher)
        '-----------------------------------------------------------------
        If SHOWDIALOG <> "" Then .ShowCategoriesDialog
 
    End With
 
    '---------------------------------------------------------------------
    ' Delete references
    '---------------------------------------------------------------------
    Set objContact = Nothing
    Set objAppointment = Nothing
    Set objCalendar = Nothing
 
End Sub