1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60
|
Sub TestColorLabel()
Dim objItem As Object
Dim thisAppt As AppointmentItem
Set objItem = Application.ActiveExplorer.Selection(1)
If objItem.Class = olAppointment Then
Set thisAppt = objItem
Call SetApptColorLabel(thisAppt, 3)
End If
Set objItem = Nothing
Set thisAppt = Nothing
End Sub
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)
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)
End If
End If
Set objMsg = Nothing
Set colFields = Nothing
Set objField = Nothing
objCDO.Logoff
Set objCDO = Nothing
End Sub |
Partager