Outlook Technologies

Outlook Forms

Languages

Samples

More Outlook Resource Sites

Microsoft Developer Network (MSDN)

FAQs and other general resources

share code 09-Sep-2010 06:15

Looking for help with Outlook programming projects — VSTO, add-ins, VBA, custom Outlook forms, etc.? You′ve come to the right place!

NEW! >> Subscribe to this site via RSS. For more RSS options, see the complete list of feeds on our main news page.

Code level: advanced Code area: Outlook Expert Techniques Printer Friendly Version
Title: GetCalendarLabels() function to return calendar color label list
Description: The customized text for calendar color labels in Outlook 2002 and later is stored in a MAPI property on the individual calendar folder. This VBA sample shows how to retrieve that list using CDO 1.21.
Date: 15-Feb-2005 00:34
Code level: advanced
Code area: Outlook Expert Techniques
Posted by: Sue Mosher
Body: Sub ShowCalLabels() Dim objNS As Outlook.NameSpace Dim objFolder As Outlook.MAPIFolder Dim strLabelList As String Dim strMsg As String Dim arr On Error Resume Next Set objNS = Application.GetNamespace("MAPI") Set objFolder = objNS.PickFolder If Not objFolder Is Nothing Then If objFolder.DefaultItemType = olAppointmentItem Then strLabelList = GetCalendarLabels(objFolder) If strLabelList = "" Then MsgBox "No custom calendar labels are present in this folder." Else arr = Split(strLabelList, ";") For i = 0 To UBound(arr) If arr(i) = "" Then strMsg = strMsg & vbCrLf & "-- no custom label --" Else strMsg = strMsg & vbCrLf & arr(i) End If Next MsgBox "Here are the labels for this folder:" & vbCrLf & strMsg End If End If End If Set objNS = Nothing Set objFolder = Nothing End Sub Function GetCalendarLabels(objFolder As Outlook.MAPIFolder) As String ' returns labels as semicolon-delimited string Dim cdoSession As MAPI.Session Dim cdoFolder As MAPI.Folder Dim cdoField As MAPI.Field Dim strLabels As String Dim strLabelName As String Dim strAllLabels As String Dim strChar As String Dim j As Integer Set cdoSession = CreateObject("MAPI.Session") cdoSession.Logon "", "", False, False Set cdoFolder = cdoSession.GetFolder(objFolder.EntryID, objFolder.StoreID) Set cdoField = cdoFolder.Fields(&H36DC0102) If Not cdoField Is Nothing Then ' handle value as a string even though it's really binary strLabels = cdoField.Value ' ignore first four zeroes 00 ' and handle each four characters as a block For j = 1 To Len(strLabels) \ 4 strChar = Mid(strLabels, (4 * j) + 1, 4) If strChar <> "0000" Then strLabelName = strLabelName & Hex4ToString(strChar) Else ' we've reached a delimiter between labels strAllLabels = strAllLabels & ";" & strLabelName strLabelName = "" End If Next GetCalendarLabels = Mid(strAllLabels, 2) End If cdoSession.Logoff Set cdoSession = Nothing Set cdoFolder = Nothing Set cdoField = Nothing End Function Public Function Hex4ToString(Data As String) As String ' Input: four-character strings, e.g. "3204" for lower-case Russian B, ' "6500" for ASCII e ' Output: correct characters ' needs to reverse order of bytes to 0432 and make it Hex, then convert Dim strTemp As String Dim strAll As String For i = 1 To Len(Data) Step 4 strTemp = Mid(Data, i, 4) strTemp = "&H" & Right(strTemp, 2) & Left(strTemp, 2) strAll = strAll & ChrW(CDec(strTemp)) Next Hex4ToString = strAll End Function
All 16comments

	Page [ 1 2 Next >> ]
	Sue Mosher 15-Feb-2005 08:40 NOTES: 1) The heart of the sample is the GetCalendarLabels() function, which takes an Outlook MAPIFolder as its argument and returns a semicolon-delimited list of the custom label texts. 2) The ShowCalLabels() subroutine demonstrates the usage of GetCalendarLabels, prompting the user to choose a folder and displaying the custom label texts in a MsgBox. 3) The MAPI property contains only customized texts, not the complete list of calendar color labels that the user sees. If a particular label has not been customized, the MAPI property will no contain a value for that label. 4) Color label texts can contain non-ASCII characters. The GetCalendarLabels() function handles those characters properly, but the MsgBox in ShowCalLabels can display them only as question marks. 5) The &H36DC0102 property is actually a binary property, so processing it as a string as I've done here is a bit of a hack. Dmitry suggests that it may be easier to do with Redemption, which will return the property as a variant array, rather than a hex-encoded string. That will be one of my next projects.
	Sue Mosher 15-Feb-2005 08:41 For a sample that shows how to set the color label on an individual appointment item, see http://www.outlookcode.com/codedetail.aspx?id=139 .
	Sue Mosher 15-Feb-2005 08:45 With regard to note #3 above, I thought it might be useful to post the default labels. This list is from a machine using U.S. English: Important Business Personal Vacation Must Attend Travel Required Needs Preparation Birthday Anniversary Phone Call Perhaps others using Outlook in different languages could post the default lists that they see.
	Sue Mosher 15-Feb-2005 14:47 For code to set the color labels, see http://www.outlookcode.com/codedetail.aspx?id=757 .
	Sue Mosher 17-Feb-2005 09:45 For a CommandBars approach to the getting the text of the color labels, see http://www.outlookcode.com/codedetail.aspx?id=763
	Sue Mosher 17-Feb-2005 09:51 Again, with regard to note #3, I've posted a new sample at http://www.outlookcode.com/codedetail.aspx?id=763 that uses CommandBars techniques to get the list of the user's actual labels in any folder, including localized default labels that haven't been customized.
	Steve 20-Feb-2005 21:19 Sue, If I have a series of Exchange Public Folder calendars, and I want custom labels to appear the same for all calendars for all users, how can I copy the settings programmatically? Is this on a per calendar basis, or a per user basis? I'm confused.
	Sue Mosher 21-Feb-2005 08:47 The color calendar label settings are per-folder, which is why the code above uses CDO to work with the &H36DC0102 property of the folder.
	Jessica Ma 14-Mar-2005 14:15 I use Call SetApptColorLabel(myItem, 6) to set the appointment color, but no color shows at all, It's color still white, why? Private Sub SetApptColorLabel(objAppt 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 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) objField.Value = intColor 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
	Sue Mosher 15-Mar-2005 08:36 Jessica, how are you instantiating myItem? If you comment out the On Error Resume Next statement, do you get any errors?
	Page [ 1 2 Next >> ]

name email