View Single Post
  #2  
Old August 30th 06, 08:24 PM posted to microsoft.public.outlook.program_vba
Sue Mosher [MVP-Outlook]
external usenet poster
 
Posts: 11,651
Default Appointment Label Color

YOu won't see any errors until you comment out the On Error Resume Next statement.

Have you checked to see whether CDO is installed on this machine?

--
Sue Mosher, Outlook MVP
Author of Configuring Microsoft Outlook 2003
http://www.turtleflock.com/olconfig/index.htm
and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
http://www.outlookcode.com/jumpstart.aspx

"OscarM" wrote in message ...
Hi,

I'm using the source code from
http://www.outlookcode.com/codedetail.aspx?id=139 along with CDO 1.21 to set
a calendar color label in Outlook.

It works from one pc, but it does not work from others. There are no errors.

Please help.

This is the code I'm using:

Dim objAppt As Outlook.AppointmentItem
Dim objFolder As MAPIFolder

' get Kaltron Calendar
Set objFolder = GetFolder("Public Folders/All Public Folders/Inbound
Water Transit")
' Set objFolder = GetFolder("Public Folders/Favorites/Inbound Water
Transit")

' create appointment on Kaltron Calendar
Set objAppt = objFolder.Items.Add("IPM.Appointment")

' set appointment properties
With objAppt
.Start = Me![EST SHIP DATE]
.Subject = "TEST PO #" & Me!PO & " " & Me!PRODUCT & " (" & Me![LOC
CODE] & ")"
.Body = "TEST PO #" & Me!PO & " " & Me!PRODUCT & " (" & Me![LOC CODE]
& ")"
.AllDayEvent = True
.Save

' set appointment label color based on LOC CODE
If Me![LOC CODE] = "KP" Then
Call SetApptColorLabel(objAppt, 3) 'green
ElseIf Me![LOC CODE] = "KUP" Then
Call SetApptColorLabel(objAppt, 2) 'blue
ElseIf Me![LOC CODE] = "DIRECT" Then
Call SetApptColorLabel(objAppt, 10) 'yellow
Else
Call SetApptColorLabel(objAppt, 1) 'red
End If

.Close (olSave)
End With



Sub SetApptColorLabel(objAppt1 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
On Error Resume Next

Set objCDO = CreateObject("MAPI.Session")
objCDO.Logon "", "", False, False
If Not objAppt1.EntryID = "" Then
Set objMsg = objCDO.GetMessage(objAppt1.EntryID, _
objAppt1.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(objAppt1, intColor)
Else
Exit Sub
End If
End If

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



Ads