Hi,

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?

Cheers,

Paul

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 =
objNamespace.GetFolderFromID("00000000AAAEAB88111B B14FB3930A1FFF7C2A9101000EF192502C04154AB66E62534A EC6E18002B0EF780E70000")


For Each objAppointement In objFolder.Items
DoEvents
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
Next


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
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)
Else
Exit Sub
End If
End If

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

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
that.

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.

--
Ken Slovak
[MVP - Outlook]
http://www.slovaktech.com
Author: Professional Programming Outlook 2007.
Reminder Manager, Extended Reminders, Attachment Options.
http://www.slovaktech.com/products.htm


"Paul" wrote in message
...
Hi,

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?

Cheers,

Paul

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 =
objNamespace.GetFolderFromID("00000000AAAEAB88111B B14FB3930A1FFF7C2A9101000EF192502C04154AB66E62534A EC6E18002B0EF780E70000")


For Each objAppointement In objFolder.Items
DoEvents
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
Next


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
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)
Else
Exit Sub
End If
End If

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