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
Similar Threads
