How to Add Colour to the Appointment Items in Outlook 2002 and upwards.
This code will not work with previous versions of Outlook as the Label Colour was added in Outlook 2002.
LOCAL loOutlook AS Outlook.Application
LOCAL loNameSpace AS Outlook.NameSpace
LOCAL loAppoint AS Outlook.AppointmentItem
loOutlook = CREATEOBJECT('Outlook.Application')
loNameSpace = loOutlook.GetNamespace("MAPI")
loNameSpace.Logon
loAppoint = loOutlook.CreateItem( 1 ) && olAppointmentItem
WITH loAppoint AS Outlook.AppointmentItem
.Subject = "Test for Change of Label Colour"
.Start = DATETIME() + (60 * 60) && Add an Hour.
.Save && Need to Save for EntryID, this is then used to change the label.
=SetAppointmentLabelColour( loAppoint, 6) && 0 = None, 1 to 10
ENDWITH
loAppoint = .NULL.
loNameSpace = .NULL.
loOutlook = .NULL.
PROCEDURE SetAppointmentLabelColour( toApp AS Outlook.AppointmentItem, ;
tnColor AS Integer )
*-- Original VBA code by Sue Mosher, converted to VFP by S.Arnold.
*-- Requires CDO 1.21
LOCAL lcCDOPropSetID1 AS String, lcCDOAppt_Color AS String
LOCAL loCDO AS MAPI.Session
LOCAL loMsg AS MAPI.Message
LOCAL loFields AS MAPI.Fields
LOCAL loField AS MAPI.Field
LOCAL lcMsg AS String
lcCDOPropSetID1 = "0220060000000000C000000000000046"
lcCDOAppt_Colors = "0x8214"
loCDO = CREATEOBJECT('MAPI.Session')
loCDO.Logon(,,.F.,.F.)
IF !EMPTY(toApp.EntryID)
loMsg = loCDO.GetMessage(toApp.EntryID,toApp.Parent.StoreID)
loFields = loMsg.Fields
loField = loFields.Item(lcCDOAppt_Colors,lcCDOPropSetID1)
IF ISNULL(loField)
&& The 3 in the parameters represents vbLong type.
loField = loFields.Add(lcCDOAppt_Colors,3,tnColor,lcCDOPropSetID1)
ELSE
loField.Value = tnColor
ENDIF
loMsg.Update(.T.,.T.)
ELSE
lcMsg = "You must save the appointment before you add a color label. " + ;
"Do you want to save the appointment now?"
IF MESSAGEBOX(lcMsg,36,"Set Appointment Color Label") = 6
=SetAppColorLabel(toApp,tnColor)
ENDIF
ENDIF
loMsg = .NULL.
loFields = .NULL.
loField = .NULL.
loCDO.Logoff
loCDO = .NULL.
ENDPROC