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.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
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 |
You must log in to post a comment.