Mysteries of the Outlook calendar labels??

[paulmcdonnell]

Hi,

Does anyone have any advice on how to change the label colour ('color' for ur US friends ) when you add calendar appoinments in outlook.

I need different appointment types to show as differently

It's not as simple as
With outappt
.label = xxxx

(which ould be nice)

as I understand it you need to save to appointment and then change later, but with some code snippets I found i've not had much success with.

My VBA understanding here is not that great and Whilst I'm using the MAPI outlook method, not sure how to use CDO (if this is what needs to be done)

Is there a strightfoward (few line) solution to this or do I need to alter a lot of my coding here..

I've listed the code that I use below so you can see where I'm at.

Hope you can help
thanks a million
Paul


I currently use:

Dim outobj As Outlook.Application
Dim outappt As Outlook.AppointmentItem
Dim ttime As Outlook.AppointmentItem
Set outobj = CreateObject("outlook.application")
Set outappt = outobj.CreateItem(olAppointmentItem)
Set outappt = offolder.Items.add(olAppointmentItem)
 
'change to meeting if inviting client
If Me.Invitecheck = -1 Then outappt.MeetingStatus = Outlook.OlMeetingStatus.olMeeting
 
'MsgBox "About to add appt. who is: " & who
            With outappt
               .start = Me!App_date & " " & Me!App_time
               .Duration = 60
               .subject = Me.App_type & ": '" & Me.Forename & " " & Me.Surname & "' (" & Me.company & " - " & Me.Maintel & "/" & Me.tel & ") with " & Me.partnerfullname & " (SJP Wealth Management) @ " & format(Me.App_time, "hh:mm") & " (For more details, open appointment...)"
               .ReminderOverrideDefault = True
                .ReminderMinutesBeforeStart = 240
               .ReminderSet = True
               .body = vbCrLf & Me.Forename & " " & Me.Surname & " of " & Me.company & " Tel: - " & Me.Maintel & " / " & Me.tel & vbCrLf & vbCrLf & "SJP contact: " & vbCrLf & "Clearwater Wealth Management" & vbCrLf & "St James's Place Wealth Management" & vbCrLf & "3 Moorgate Place" & vbCrLf & "London" & vbCrLf & "EC2R 6EA" & vbCrLf & "Tel: " & AppointerTel & vbCrLf & "Fax: 0207 744 4402" & vbCrLf & vbCrLf & vbCrLf & "Partner Info:" & vbCrLf & Me.partnerfullname & vbCrLf & "Contact Numbers : " & PartnerTelnos & vbCrLf & "Contact email : " & Me.seenbyemail & vbCrLf & vbCrLf & vbCrLf & "Origin date : " & Date & vbCrLf & "Ref: " & Me!CallID
               .BusyStatus = olTentative
               .Location = Me.Location & " " & Me.Notes & "-"
               If Me.Seen_by = "PrM" Then .BusyStatus = olTentative Else If Me.Location = "Inhouse" Then .BusyStatus = olBusy Else .BusyStatus = olOutOfOffice
               'If Me.ttimetag = -1 Then .BusyStatus = olOutOfOffice
               If Me.Invitecheck = -1 Then .body = .body & vbCrLf & vbCrLf & "[Inv Snt - " & Date & "]" 'NEW for 7/01/09
               If Me.Check37.Value = -1 Then .body = .body & "[E-conf snt- " & Me.App_date & "]" 'NEW for 7/01/09
               If Me.Check39.Value = -1 Then .body = .body & "[Auto Rem - " & Me.App_date - Me.daysbefore & " @ " & Me.App_time & "]" 'NEW for 7/01/09
               If Me.Invitecheck = -1 Then .Recipients.add (Me.email)
               If Me.Invitecheck = -1 And Me.showinvite = -1 Then
               .display
               ElseIf Me.Invitecheck = -1 And IsNull(Me.showinvite) Or Me.Invitecheck = -1 And Me.showinvite = 0 Then
               .send
               End If
               .save
                              
            End With

Some code I found but couldn't get my head around

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