Sub SetApptColorLabel(objAppt As Object, _
                      intColor As Integer)
        '1=Важно, 2=Служебное и тд.
    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 = "Вы должны сначала сохранить объект. Сохранить?"
        intAns = MsgBox(strMsg, vbYesNo + vbDefaultButton1, "Установка цвета")
        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