Neue Aufgabe mit Kontakt

Ähnlich dem Programmierbeispiel Neuer Termin mit Kontakt, finden Sie hier die Funktion "Neue Aufgabe mit Kontakt".

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 NewTaskWithContact()
 
    '=====================================================================
    ' Erstellt eine Aufgabe zum geöffneten bzw. markiertem Kontakt.
    ' (c) Peter Marchert - http://www.outlook-stuff.com/
    ' 2008-12-07 Version 1.0.0
    '=====================================================================
 
    Dim objTasks As Outlook.MAPIFolder       ' Aufgabenordner
    Dim objTask As Outlook.TaskItem          ' Neue Aufgabe
    Dim objContact As Outlook.ContactItem    ' Kontakt
 
    '---------------------------------------------------------------------
    ' Nachfolgende Konstanten mit "" vorbelegen, wenn nicht gewünscht
    '---------------------------------------------------------------------
    Const MYCATEGORIES As String = "Geschäftlich"  ' Kategorie (mehrere
                                                   ' durch ";" trennen)
    Const PERSONAL As String = ""              ' "Wahr", wenn Private Aufgabe
    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, "Neue Aufgabe mit Kontakt"
        Exit Sub
    End If
 
    '---------------------------------------------------------------------
    ' Aufgabenordner referenzieren
    '---------------------------------------------------------------------
    Set objTasks = Outlook.Session.GetDefaultFolder(olFolderTasks)
 
    '---------------------------------------------------------------------
    ' Neue Aufgabe erstellen
    '---------------------------------------------------------------------
    Set objTask = objTasks.Items.Add
 
    '---------------------------------------------------------------------
    ' Aufgabe mit Werten füllen
    '---------------------------------------------------------------------
    With objTask
 
        '-----------------------------------------------------------------
        ' Betreff festlegen
        '-----------------------------------------------------------------
        .Subject = "Aufgabe mit " & objContact.Subject 
 
        '-----------------------------------------------------------------
        ' Konstanten berücksichtigen
        '-----------------------------------------------------------------
        If MYCATEGORIES <> "" Then .Categroies = MYCATEGORIES
        If PERSONAL <> "" Then .Sensitivity = olPrivate
 
        '-----------------------------------------------------------------
        ' Kontakt als Link einfügen
        '-----------------------------------------------------------------
        Call .Links.Add(objContact)
 
        '-----------------------------------------------------------------
        ' Aufgabe anzeigen
        '-----------------------------------------------------------------
        .Display
 
        '-----------------------------------------------------------------
        ' Dialog zur Kategorieauswahl anzeigen? (erst ab 2002)
        '-----------------------------------------------------------------
        If SHOWDIALOG <> "" Then .ShowCategoriesDialog
 
    End With
 
    '---------------------------------------------------------------------
    ' Referenzen löschen
    '---------------------------------------------------------------------
    Set objContact = Nothing
    Set objTask = Nothing
    Set objTasks = Nothing
 
End Sub