VBA to change the color of an entry in Outlook Calendar

[ReportTeam]

Hi

I was wondering if anyone had sample code showing how the color of an entry in an Outlook Calendar can be changed.

Thanks

[Charlize]

I believe this one will do the trick for you (2003).
Sub Give_Label_Color_To_Selection()
'Original coding from
'http://www.outlookcode.com/codedetail.aspx?id=139
Dim objItem As Object
Dim thisAppt As AppointmentItem
'An item must be selected or you'll get an error message
Set objItem = Application.ActiveExplorer.Selection(1)
If objItem.Class = olAppointment Then
Set thisAppt = objItem
'you can use 1 to 10
Call SetApptColorLabel(thisAppt, 3)
End If
Set objItem = Nothing
Set thisAppt = Nothing
End Sub
Sub SetApptColorLabel(objAppt As Outlook.AppointmentItem, _
intColor As Integer)
' requires reference to CDO 1.21 Library
' adapted from sample code by Randy Byrne
' intColor corresponds to the ordinal value of the color label
'1=Important, 2=Business, etc.
Const CdoPropSetID1 = "0220060000000000C000000000000046"
Const CdoAppt_Colors = "0x8214"
Dim objCDO As MAPI.Session
Dim objMsg As MAPI.Message
Dim colFields As MAPI.Fields
Dim objField As MAPI.Field
Dim strMsg As String
Dim intAns As Integer
'continue if an error occures
On Error Resume Next
'create a session
Set objCDO = CreateObject("MAPI.Session")
objCDO.Logon "", "", False, False
If Not objAppt.EntryID = "" Then
Set objMsg = objCDO.GetMessage(objAppt.EntryID, _
objAppt.Parent.StoreID)
Set colFields = objMsg.Fields
Set objField = colFields.item(CdoAppt_Colors, CdoPropSetID1)
If objField Is Nothing Then
Err.Clear
Set objField = colFields.Add(CdoAppt_Colors, vbLong, intColor, CdoPropSetID1)
Else
objField.Value = intColor
End If
objMsg.Update True, True
Else
strMsg = "You must save the appointment before you add a color label. " & _
"Do you want to save the appointment now?"
intAns = MsgBox(strMsg, vbYesNo + vbDefaultButton1, "Set Appointment Color Label")
If intAns = vbYes Then
Call SetApptColorLabel(objAppt, intColor)
End If
End If
'Clearing the objects
Set objMsg = Nothing
Set colFields = Nothing
Set objField = Nothing
objCDO.Logoff
Set objCDO = Nothing
End SubCharlize