Bonjour,
Je vous expose la situation : j'ai besoin de créer des RDV dans OUTLOOK depuis un fichier Excel en reprenant les infos présentes dans différentes lignes/colonnes d'une feuille.
Le code fonctionne normalement, le souci que je rencontre est qu'il ne fonctionne que sur mon calendrier, et quand je veux changer de calendrier avec Set Recipient = Namespace.CreateRecipient("tata@tata.fr"), les RDV se créent toujours dans mon calendrier Outlook ex : "toto@toto.fr".
Ces adresses sont évidemment bidons, mais les vraies adresses de calendrier correspondent à des calendrier sur lesquels j'ai bien tous les droits d'écriture (je peux ajouter des RDV à la main sans difficulté dans ces cal).
Voici mon code :Pouvez-vous me dire comment accéder à un autre calendrier via ce code, SVP ?
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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 Sub ajoutCalendrierTest() Dim objOutlook, Namespace As Object 'Dim choix As Integer Dim Recipient As Outlook.Recipient Dim OutAppt As Outlook.AppointmentItem Dim derlignetest, i As Long Dim datedeb As Date Dim datefin As Date Set objOutlook = New Outlook.Application Set Namespace = Outlook.GetNamespace("MAPI") Set Recipient = Namespace.CreateRecipient("toto@toto.fr") 'Recipient.Resolve Application.ScreenUpdating = False ' Masque le déroulement de la macro Application.DisplayAlerts = False ' Sheets("Test").Select With Sheets("Test") derlignetest = Sheets("Test").Range("A200000").End(xlUp).Row For i = 2 To derlignetest '!!! Faire un controle pour savoir si RDV déjà indiqué !!! datedeb = Range("C" & i) datefin = Range("D" & i) Set OutAppt = objOutlook.CreateItem(olAppointmentItem) 'Objet RDV Outlook With OutAppt .Subject = Sheets("Test").Range("B" & i) 'Objet du mail .Body = "Nombre de CR impactées : " & Sheets("Test").Range("L" & i) & Chr(10) & Chr(10) & "Nom des CR : " & Sheets("Test").Range("G" & i) & Chr(10) & Chr(10) & "Nom du service impacté : " & Sheets("Test").Range("E" & i) & Chr(10) & Chr(10) & "Remarques : " & Chr(10) & Sheets("Test").Range("K" & i) & Chr(10) & Chr(10) & "Interruption de service : " & Sheets("Test").Range("H" & i) & Chr(10) & Chr(10) & "Relations Partenaires : " & Sheets("Test").Range("I" & i) 'Corps du message .Start = datedeb 'date début d'intervention .End = datefin 'date fin d'intervention '.Duration = datefin - datedeb pas nécessaire .ReminderSet = False 'on ne met pas de rappel .Save 'enregistrement du RDV End With On Error Resume Next Next i End With Set objOutlook = Nothing Set Namespace = Nothing Set Recipient = Nothing Sheets("Test").Select End Sub
En vous remerciant par avance,
Xico
Partager