Discussion :

[vincentariaux]

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 :

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
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

[vincentariaux]

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 :

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
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

[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 !