Flag a Contact For Follow-Up

The object model of Outlook 2003 doesn't support flagging contacts. However, it's possible with the CDO 1.21 library.

  How to add macros to Outlook

Public 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
    ' Delete Flag 
    DeleteField oFields, CdoPR_FLAG_STATUS
    DeleteField oFields, CdoPR_FLAG_DUE_BY
    DeleteField oFields, CdoPR_FLAG_TEXT

  Case 1
    ' White Flag (completed)
    AddField oFields, CdoPR_FLAG_STATUS, vbLong, lFlagStatus

  Case 2
    ' Red 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

This calls the macro for the contact item selected in the folder, sets the message to 'Call' and the due date on next week:

Public Sub FlagContact()
  Dim Contact As Outlook.ContactItem
  Dim Due As Date, Msg As String
  
  'Due in seven days
  Due = DateAdd("d", 7, Date)
  Msg = "Call"

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