attribuer une couleur à un RDV [Résolu]

[isa38]

Bonjour,

depuis mon application ACCESS 2003, je souhaite inscrire des RDV dans un calendrier Outlook 2003 en VBA.

Ca j'arrive à le faire.
Mais je voudrais pouvoir attribuer une couleur corespondant à une catégorie du calendrier (important, personnel,...).
Je cherche depuis pas mal d'heures mais je ne trouve pas la propriété correspondante

Si quelqu'un a la solution, merci de me l'indiquer !

[isa38]

A force de surfer, j'ai fini par trouver. Je copie ici le code que j'ai trouvé sur :
http://www.outlookcode.com/codedetail.aspx?id=139

au cas où cela en intéresserait d'autres !

Code :

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

Et ça marche