Flagging Your Contacts With Code
UPDATE, 8/9/2004: There was a bug in my code! I was forgetting to set CdoPR_REMINDER_SET to 'True'; thanks to Fred for pointing out the error, and to Dmitry for soothing my brain cramp by pointing out I that have to use CdoPropSetID4 when setting that property. All modifications of the code since the last post are preceded with '** comments on the previous line.
Why, oh WHY, does working with flag information for Contacts in VBA differ so greatly compared with MailItem or MeetingItem objects? I don't know! But they do! It's easy for those objects:
objMail.FlagStatus = olFlagMarked
objMail.FlagRequest = "Follow up"
objMail.FlagDueBy = "05/27/2004 15:30 PM"
That's all there is to it! But those Flag_ properties do not exist for ContactItems. You need to use CDO and some undocumented methods to save these values.
The necessary CDO properties that you need to work with are obvious at first: CdoPR_FLAG_TEXT, CdoPR_FLAG_STATUS, CdoPR_FLAG_DUE_BY and CdoPR_REMINDER_SET. However, the sneaky bits are the other properties that you have to set that are non-intuitive: CdoPR_REPLY_REQUESTED, CdoPR_RESPONSE_REQUESTED, CdoPR_FLAG_DUE_BY_NEXT and CdoPR_REPLY_TIME.
Put the code below into a Module in your Outlook VBA project, making sure that you have a reference set to the Microsoft CDO 1.21 library. Then select any test Contact and run the procedure to see how the flag information is manipulated. Modify the code to suit any solution that you need it for.
Option Explicit
Const CdoPropSetID4 = "0820060000000000C000000000000046"
Const CdoPR_FLAG_TEXT = "{" & CdoPropSetID4 & "}" & "0x8530" 'String
Const CdoPR_FLAG_DUE_BY = "{" & CdoPropSetID4 & "}" & "0x8502" 'Date
Const CdoPR_FLAG_DUE_BY_NEXT = "0x8560" 'Date
Const CdoPR_REPLY_REQUESTED = &HC17000B 'True/False
Const CdoPR_RESPONSE_REQUESTED = &H63000B 'True/False
Const CdoPR_REPLY_TIME = &H300040 'Date
Const CdoPR_FLAG_STATUS = &H10900003
'** I forgot this constant before!
Const CdoPR_REMINDER_SET = "{" & CdoPropSetID4 & "}" & "0x8503"
Sub SetFlagInfoForSelectedContact()
On Error Resume Next
Dim objSession As MAPI.Session, objCDOContact As MAPI.Message
Dim objNS As Outlook.NameSpace, objOLContact As Outlook.ContactItem
Dim objFields As MAPI.Fields, objField As MAPI.Field
Dim strValue As String, strTempDate As String, dteFlagDate As Date
If Application.ActiveExplorer.Selection.Count > 1 Then Exit Sub
Set objOLContact = Application.ActiveExplorer.Selection(1)
If objOLContact.Class <> Outlook.OlObjectClass.olContact Then Exit Sub
Set objNS = Application.GetNamespace("MAPI")
Set objSession = New MAPI.Session
objSession.Logon , , , False
'**check for any logon errors
If Err.Number <> 0 Then GoTo Leave:
Set objCDOContact = objSession.GetMessage(objOLContact.EntryID, Application.ActiveExplorer.CurrentFolder.StoreID)
'**check for a valid CDO Message
If objCDOContact Is Nothing Then GoTo Leave:
strValue = InputBox("Flag Text value: ", , "Follow up")
If strValue = "" Then
MsgBox "Invalid Flag text"
GoTo Leave:
End If
'DateTime format = m/dd/yyyy hh:mm AM/PM; eg. 5/27/2004 15:00 PM
strTempDate = (InputBox("Flag reminder date (m/dd/yyyy hh:mm AM/PM):"))
If IsDate(strTempDate) = False Then
MsgBox "Invalid date."
GoTo Leave:
End If
dteFlagDate = CDate(strTempDate)
Set objFields = objCDOContact.Fields
objFields.Add CdoPR_FLAG_STATUS, 2
objFields.Add CdoPR_REPLY_REQUESTED, True
objFields.Add CdoPR_RESPONSE_REQUESTED, True
objFields.Add CdoPR_FLAG_TEXT, 8, strValue, CdoPropSetID4
objFields.Add CdoPR_FLAG_DUE_BY, 7, dteFlagDate, CdoPropSetID4
objFields.Add CdoPR_FLAG_DUE_BY_NEXT, 7, dteFlagDate, CdoPropSetID4
objFields.Add CdoPR_REPLY_TIME, dteFlagDate
'**
objFields.Add CdoPR_REMINDER_SET, 11, True, CdoPropSetID4
objCDOContact.Update
Leave:
If Not objSession Is Nothing Then objSession.Logoff
If Not objNS Is Nothing Then objNS.Logoff
Set objSession = Nothing
Set objCDOContact = Nothing
Set objOLContact = Nothing
Set objNS = Nothing
Set objFields = Nothing
Set objField = Nothing
End Sub