Kontakte zur Nachverfolgung kennzeichnen

Das Objektmodell von Outlook 2003 bietet keine Möglichkeit, Kontakte zu kennzeichnen. Mit der CDO 1.21 Bibliothek geht es aber.

  So fügen Sie Makros in Outlook ein

Private Sub FlagContact_Ex(oContact As Outlook.ContactItem, _
  ByVal lFlagStatus As Long, _
  ByVal dtFlagDueBy As Date, _
  sFlagText As String _
)
  Dim oMsg As MAPI.Message
  Dim oFields As MAPI.Fields

  Const CdoPropSetID4 As String = "0820060000000000C000000000000046"
  Const CdoPR_FLAG_STATUS As Long = &H10900003
  Const CdoPR_FLAG_DUE_BY As String = "{" & CdoPropSetID4 & "}" & "0x8502"
  Const CdoPR_FLAG_TEXT As String = "{" & CdoPropSetID4 & "}" & "0x8530"

  Set oMsg = GetMessage(oContact)
  Set oFields = oMsg.Fields

  Select Case lFlagStatus
  Case 0
    ' Flag löschen
    DeleteField oFields, CdoPR_FLAG_STATUS
    DeleteField oFields, CdoPR_FLAG_DUE_BY
    DeleteField oFields, CdoPR_FLAG_TEXT

  Case 1
    ' Weißes Flag (erledigt)
    AddField oFields, CdoPR_FLAG_STATUS, vbLong, lFlagStatus

  Case 2
    ' Rotes Flag
    AddField oFields, CdoPR_FLAG_STATUS, vbLong, lFlagStatus
    AddField oFields, CdoPR_FLAG_DUE_BY, vbDate, dtFlagDueBy
    AddField oFields, CdoPR_FLAG_TEXT, vbString, sFlagText
  End Select

  oMsg.Update True
End Sub

Private Sub AddField(oFields As MAPI.Fields, _
  PropTag As Variant, _
  DataType As Variant, _
  Value As Variant _
)
  On Error Resume Next
  Dim oField As MAPI.Field

  Set oField = oFields(PropTag)
  If oField Is Nothing Then
    Set oField = oFields.Add(PropTag, DataType)
  End If
  oField.Value = Value
End Sub

Private Sub DeleteField(oFields As MAPI.Fields, _
  PropTag As Variant _
)
  On Error Resume Next
  Dim oField As MAPI.Field

  Set oField = oFields(PropTag)
  If Not oField Is Nothing Then
    oField.Delete
  End If
End Sub

So rufen Sie die Funktion z.B. für einen im Ordner ausgewählten Kontakt auf, setzen den Text auf 'Anrufen' und die Fälligkeit auf nächste Woche:

Public Sub FlagContact()
  Dim Contact As Outlook.ContactItem
  Dim Due As Date, Msg As String
  
  'Fällig in sieben Tagen
  Due = DateAdd("d", 7, Date)
  Msg = "Anrufen"

  Set Contact = Application.ActiveExplorer.Selection(1)
  FlagContact_Ex Contact, 2, Due, Msg
End Sub