Setting appointment label




I'm using office 2003.

I'm using the code below to change the label for my appointments based on
the subject contents, but when I run the code not all the appointments are
changed to the assigned label. Some will stay white...

Any ideas anybody?



Sub Label()

Dim objOutlook As New Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim objAppointement As Outlook.AppointmentItem
Dim objAttachment As Outlook.Attachment
Dim objNetwork As Object
Dim lngDeletedAppointements As Long
Dim lngCleanedAppointements As Long
Dim lngCleanedAttachments As Long
Dim blnRestart As Boolean
Dim intDateDiff As Integer

Set objOutlook = Outlook.Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder =

For Each objAppointement In objFolder.Items
If objAppointement.Subject = "x" Then
Call SetApptColorLabel(objAppointement, 1)
ElseIf objAppointement.Subject = "y" Then
Call SetApptColorLabel(objAppointement, 2)
ElseIf objAppointement.Subject = "r" Then
Call SetApptColorLabel(objAppointement, 3)
ElseIf objAppointement.Subject = "t" Then
Call SetApptColorLabel(objAppointement, 4)
ElseIf objAppointement.Subject = "g" Then
Call SetApptColorLabel(objAppointement, 5)
End If

End Sub

Sub SetApptColorLabel(objAppt As Object, _
intColor As Integer)

Const CdoPropSetID1 = "0220060000000000C000000000000046"
Const CdoAppt_Colors = "0x8214"
Dim objCDO As Object
Dim objMsg As Object
Dim colFields As Object
Dim objField As Object
Dim strMsg As String
Dim intAns As Integer
On Error Resume Next

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
Set objField = colFields.Add(CdoAppt_Colors, vbLong, intColor, CdoPropSetID1)
objField.Value = intColor
End If
objMsg.Update True, True
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
If intAns = vbYes Then
Call SetApptColorLabel(objAppt, intColor)
Exit Sub
End If
End If

Set objAppt = Nothing
Set objMsg = Nothing
Set colFields = Nothing
Set objField = Nothing
Set objCDO = Nothing
End Sub

Ken Slovak - [MVP - Outlook]

Where is this code running? If it's in the Outlook VBA project you should
never use New to set an Outlook.Application object, use the intrinsic and
trusted Application object. If it's not running in Outlook then using New
set objOutlook, don't set it again.

Never hard code a folder or item EntryID. If this is the default Calendar
folder use objNamespace.GetDefaultFolder(olFolderCalendar).

Are you getting any errors? I could see problems arising from the constant
logging into and out of CDO sessions. You should do the CDO session creation
and login once and use a global or pass the CDO.Session object. CDO does
have some memory leaks when you do multiple login/logoff operations like

I'd comment the error handler so errors will fire or I'd test for errors at
critical points so I could see what's going on, either that or step the code
and see what's happening.

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question