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

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

It was not installed. That's why it was not working.

I just registered "cdo.dll" and it worked.


Thanks for your help!



"Sue Mosher [MVP-Outlook]" wrote:

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