Création rdv Outlook depuis Excel

Version imprimable

Bonjour à tous,

Je suis nouveau sur ce forum.
ingénieur mécanicien de formation (et de métier), j'ai eu besoin au fil des années de créer quelques macros afin de répondre aux différents besoin de ma petite société.

Et la, je suis confronté à un problème que je ne sais résoudre, malgré mes recherches internets.

Voici mon problème:

Nous avons dans ma boite un ficher excel commun (pas partagé mais accessible à tous) avec des dates de remise de prix.
Tout le monde rempli ce fichier en fonction de ses clients et de ses devis.
Je souhaitai créer des rdv outlook depuis cet excel(afin de ne pas zapper de remise de prix). Jusque la, pas de souci, mon code fonctionne parfaitement sur mon calendrier.

Ensuite, j'ai crée ce rdv sur un autre calendrier que j'ai crée et que j'ai partagé (la aussi tout va bien, tout le monde voit les rdv).
Mais je voudrai que les personnes à qui j'ai partagé le calendrier puisse aussi créer des rdv sur ce calendrier.(afin d'avoir un seul calendrier commun)

Et la, impossible de trouver le lien qui va bien.
Je ne sais pas comment aller chercher le calendrier partagé depuis leur machine, sachant qu'il n’apparaît pas dans la catégorie "mes calendriers" (comme sur mon poste) mais dans la catégorie "calendrier partagée"...

Je suis a sec, donc merci d'avance pour votre aide.

Je tiens à préciser que je n'ai aucune formation informatique, donc que le code est peut être "bizarre" ou "suspect" sur certains point pour un puriste. MErci de votre clémence.
Et désolé d'avance pour les futures questions que je pourrai poser qui vous paraîtront louches :-)

Merci beaucoup.

Ci joint mon code:
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 61 62 63 64 65 Sub AjoutRV() Dim DLig As Long, Lig As Long Dim DateRdv As Date, FlgRdv As Boolean Dim OutObj As Outlook.Application Dim OutAppt As Outlook.AppointmentItem Dim MyCalendar As Outlook.Items Dim NS As Outlook.Namespace Dim objOwner As Outlook.Recipient ' Créer une instance d'Outlook Set OutObj = CreateObject("outlook.application") Set NS = OutObj.GetNamespace("MAPI") Set objOwner = NS.CreateRecipient(NS.CurrentUser) objOwner.Resolve If objOwner.Resolved Then 'MsgBox objOwner.Name Set MyCalendar = OutObj.GetNamespace("MAPI").GetSharedDefaultFolder(objOwner, olFolderCalendar).Folders.Item("REMISE OFFRES").Items ' Avec la feuille With Sheets("Suivi") DLig = .Range("A" & Rows.Count).End(xlUp).Row ' Pour chaque ligne For Lig = 2 To DLig ' Si une date de relance existe If .Range("H" & Lig) <> "" Then ' Si un RDV n'a pas déjà été créé If .Range("I" & Lig) <> "" Then FlgRdv = False Else ' Sinon, pas de RDV déjà créé FlgRdv = True End If Else ' Sinon, pas de date de relance FlgRdv = False End If ' Si le FLAG est à vrai on créé le RDV If FlgRdv Then DateRdv = Range("H" & Lig) Set OutAppt = MyCalendar.Add With OutAppt .Subject = "Remise DEVIS " & Sheets("Suivi").Range("A" & Lig) & " pour " & Sheets("Suivi").Range("C" & Lig) .Start = DateRdv & " 08:00" .Duration = 60 .ReminderSet = True .Save End With ' inscrire Oui On Error Resume Next .Range("I" & Lig).Comment.Delete .Range("I" & Lig) = "Oui" On Error GoTo 0 End If Next Lig End With Set OutAppt = Nothing End If End Sub

Rebonjour,

La réponse était en moi visiblement. Cela fonctionne apès modif. Je mets à dispo le code complet pour ceux que ça intéresse.

Il permet de créer des rdv dans outlook depuis excel vers un calendrier partagé, que l'on soit le créateur du calendrier ou une des personnes a qui le calendrier est partagé.

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
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
    Sub AjoutRV()
      Dim DLig As Long, Lig As Long
      Dim DateRdv As Date, FlgRdv As Boolean
      Dim OutObj As Outlook.Application
      Dim OutAppt As Outlook.AppointmentItem
      Dim MyCalendar As Outlook.Items
      Dim NS As Outlook.Namespace
Dim objOwner As Outlook.Recipient
 
 
 
Dim ol As Outlook.Application
Dim olns As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim myFolder As Outlook.Folder
Dim objExpCal As Outlook.Explorer
Dim objNavMod As Outlook.CalendarModule
Dim objNavGroup As Outlook.NavigationGroup
Dim objNavFolder As Outlook.NavigationFolder
Dim objAppt As AppointmentItem
 
 
 
 
      ' Créer une instance d'Outlook
     Set OutObj = CreateObject("outlook.application")
 
Set ol = New Outlook.Application
Set olns = ol.Session
Set objExpCal = olns.GetDefaultFolder(olFolderCalendar).GetExplorer
Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
Set objNavGroup = objNavMod.NavigationGroups.GetDefaultNavigationGroup(olPeopleFoldersGroup)
Set objAppt = ol.CreateItem(olAppointmentItem)
If olns.DefaultStore.DisplayName = "adresse mail propriétaire calendrier" Then
'cas où le propriétaire du calendrier partagé fait l'opération
    Set myFolder = olns.GetDefaultFolder(olFolderCalendar)
    Set Mysubfolder = myFolder.Folders("nom calendrier").Items
Else
'cas où un autre utilisateur ayant les droits d'éditeur fait l'opération
   Set myRecipient = olns.CreateRecipient("propriétaire du calendrier")
       myRecipient.Resolve
    If myRecipient.Resolved Then
       Set Mysubfolder = objNavGroup.NavigationFolders("nom calendrier partagé").Folder.Items
    End If
End If
 
         ' Avec la feuille
     With Sheets("Suivi")
        DLig = .Range("A" & Rows.Count).End(xlUp).Row
        ' Pour chaque ligne
       For Lig = 2 To DLig
          ' Si une date de relance existe
         If .Range("H" & Lig) <> "" Then
            ' Si un RDV n'a pas déjà été créé
           If .Range("I" & Lig) <> "" Then
                        FlgRdv = False
                        Else
              ' Sinon, pas de RDV déjà créé
             FlgRdv = True
            End If
          Else
            ' Sinon, pas de date de relance
           FlgRdv = False
          End If
          ' Si le FLAG est à vrai on créé le RDV
         If FlgRdv Then
            DateRdv = Range("H" & Lig)
            'Set OutAppt = MyCalendar.Add
            'With OutAppt
            Set OutAppt = Mysubfolder.Add
            With OutAppt
 
              .Subject = "Remise DEVIS " & Sheets("Suivi").Range("A" & Lig) & " pour " & Sheets("Suivi").Range("C" & Lig)
              .Start = DateRdv & " 08:00"
              .Duration = 60
              .ReminderSet = True
              .Save
            End With
            ' inscrire Oui
           On Error Resume Next
            .Range("I" & Lig).Comment.Delete
            .Range("I" & Lig) = "Oui"
            On Error GoTo 0
          End If
        Next Lig
      End With
      Set OutAppt = Nothing
 
 
 
 
    End Sub

13/06/2017, 11h39
Adeline8

Bonjour,

je tente de répondre à votre message 2 ans plus tard, on verra si j'obtiens une réponse :)

déjà, merci pour ce code, car c'était un besoin pour moi aussi, et en effet ça fonctionne à merveille.
Le seul hic, c'est que quand Outlook est déjà ouvert, ça ouvre une seconde instance. est ce que c'est le cas pour vous aussi ? avez-vous trouver une solution pour ça ?

Merci énormément si vous voyez et répondez à ce message, ou si une autre personne répond !