Setting Outlook Appointment Label Color using code

Davers · Mar 23, 2004

Does anyone know how to set the label color through code? I'm using this to import several hundred appointments into my Outlook Calendar, and I'd like to set the color of them to something other than white...can this be done with code?

Code:

Sub enterAPPT()

Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olAppt As Outlook.AppointmentItem
Dim Calendar As Outlook.MAPIFolder
Dim Installers As Outlook.MAPIFolder
Dim olSub, myTime, myDate, myPeeps, myLoc, myCDSID, myDept As String

For Each i In Range("C16:C" & Range("C65536").End(xlUp).Row)
If i.Value = "" Then Exit For

myCell = i.Address
myTime = Format(Range(myCell).Offset(0, 6), "hh:mm AM/PM")
myDate = Range(myCell).Offset(0, 5)
myPeeps = Range(myCell).Offset(0, 3)
myLoc = Range(myCell).Offset(0, 4)
myCDSID = Range(myCell).Offset(0, 1).Value
myDept = Range(myCell).Offset(0, 2)

Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
olNs.Logon

Set Calendar = olNs.GetDefaultFolder(olFolderCalendar)
Set olAppt = olApp.CreateItem(olAppointmentItem)

olSub = "PC Renewal Schedule"
olAppt.Start = myTime + myDate
 
    With olAppt
        .Duration = 120
        .Subject = olSub
        .Body = myCDSID & " - " & myPeeps & " - " & olSub
        .Location = myDept & " - " & myLoc
        .ReminderMinutesBeforeStart = 30
        .ReminderSet = True
    End With
    
    olAppt.Save
Next

Set olApp = Nothing
Set olNs = Nothing
Set olAppt = Nothing
Set Calendar = Nothing

End Sub

Thanks,

Dave

TommyGun · Mar 25, 2004

Okay, first, I cannot take credit for this code...it was found here...http://www.outlookcode.com/codedetail.aspx?id=139.

This will set the label color of a saved appointment item. I have adjusted it slightly so that it does not require a reference to the CDO library to be added.

Sub SetApptColorLabel(objAppt As Object, _
 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 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


The way you would use this in your code is as follows...

olSub = "PC Renewal Schedule"
olAppt.Start = myTime + myDate

 With olAppt
 .Duration = 120
 .Subject = olSub
 .Body = myCDSID & " - " & myPeeps & " - " & olSub
 .Location = myDept & " - " & myLoc
 .ReminderMinutesBeforeStart = 30
 .ReminderSet = True
 End With

 olAppt.Save

 SetApptColorLabel olAppt, 2
Next

This has been very lightly tested, but it did seem to work on my end.

Davers · Mar 25, 2004

Ouch! Thanks for the reply TommyGun!!! I think I may just do this manually, I've found out I can color appointments based on the subject line, and since they all have "PC Renewal Schedule" as the subject, that will probably be easier...

And just for fun, I created 2 more subs, one deletes all of these appointments just in case it was a mistake....and the other will send them out...what a time saver!!!

Thanks again...I'll have to check out that web site!!!

Have a good day,

Dave

Setting Outlook Appointment Label Color using code

Davers

Well-known Member

Excel Facts

TommyGun

MrExcel MVP

Davers

Well-known Member

Similar threads

Forum statistics

Share this page

Setting Outlook Appointment Label Color using code

Davers

Well-known Member

Excel Facts

TommyGun

MrExcel MVP

Davers

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock