Discussion :

[bibichris]

Bonjour, je viens vers vous car mes recherches infructueuses et mes connaissances en VBA limitées ne m'ont pas permis de résoudre par moi-même le problème que je vais vous soumettre :

J'utilise la fonction mise au point par Macno pour ajouter un rendez-vous à un calendrier outlook. (ma config : vista pro + outlook et access 2007).
lien de la source : http://access.developpez.com/sources...endrierOutlook.

Lorsque je ne spécifie pas de calendrier particulier, donc quand la chaine PCalendrier est vide, la fonction ajoute sans problème le rendez-vous dans le calendrier par défaut à savoir "Calendrier".

Là où ça ne veut plus fonctionner, c'est quand je spécifie un calendrier différent : dans mon cas, j'ai créé un calendrier nommé "essai" au même niveau de l'arborescence que le calendrier par défaut (pas en sous-calendrier).

Je reçois systématiquement une erreur :
Error -2147221233
Impossible d'exécuter l'opération. Impossible de trouver un objet.

Voici le code tel que je l'ai modifié : j'ai simplement créer une variable supplémentaire (MyEssaiFld) pour faire des tests et visualiser le contenu de MyCalendarFolder et MyEssaiFld avec des MsgBox.

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
Public Function CreerRendezVous(PCalendrier As String, _
 PDate As String, _
 PHeure As String, _
 PDuree As Integer, _
 PSubject As String, _
 PNotes As String, _
 PLieu As String, _
 Optional PMinutesRappel As Integer = 0)
 
On Error GoTo Add_Err
 
Dim objOutlook As Outlook.Application
Dim objAppt As Outlook.AppointmentItem
Dim olns As Outlook.NameSpace
Dim MycalendarFolder As Outlook.MAPIFolder
Dim MyEssaiFld As Outlook.MAPIFolder
Dim MyFolder As Outlook.Items
 
Set objOutlook = CreateObject("Outlook.Application")
Set olns = objOutlook.GetNamespace("MAPI")
Set MycalendarFolder = olns.GetDefaultFolder(olFolderCalendar)
 
MsgBox MycalendarFolder
 
Set MyEssaiFld = olns.Folders(PCalendrier)
 
MsgBox MyEssaiFld
 
'Selectionne le calendrier
If PCalendrier = "" Then
Set MyFolder = MycalendarFolder.Items
Else
Set MyFolder = MycalendarFolder.Folders(PCalendrier).Items
End If
Set objAppt = MyFolder.Add
'Cree le rendez vous
With objAppt
 
  If PDuree > 0 Then
  .Start = PDate & " " & PHeure
  .Duration = PDuree
  Else
  .Start = PDate
  .AllDayEvent = True
  End If
  .Subject = PSubject
  .Body = PNotes
  .Location = PLieu
  'Ajoute le rappel
  If PMinutesRappel > 0 Then
    .ReminderMinutesBeforeStart = PMinutesRappel
    .ReminderSet = True
  End If
  'Sauvegarde et ferme
  .Save
  .Close (olSave)
End With
'Libération des variables.
Set objAppt = Nothing
Set objOutlook = Nothing
MsgBox "Rdv ajouté!"
Exit Function
'Gere les erreurs
Add_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
End Function

Merci d'avance pour votre réponse. Chris.
PS : je pense que le problème viens de l'utilisation des chemins d'accès avec olns.Folders(PCalendrier) etc.. mais malgré les essais et les infos glanées sur l'utilisation de ces chemins, je n'arrive pas à me dépatouiller.

Voilà aussi les infos que j'ai pu glaner deci-delà:
http://excel.developpez.com/faq/?pag...AjouterContact
http://support.microsoft.com/kb/469686/fr
http://support.microsoft.com/kb/468547/fr
http://support.microsoft.com/kb/310244/fr

[bibichris]

A y est !!

A tête reposée, ça marche toujours mieux !

J'ai trouvé une solution qui fonctionne pour mon problème. C'est peut-être pas très orthodoxe mais ça marche.
Je suis tombé sur une source pour insérer des rendez-vous dans un sous-calendrier et j'ai simplement récupérer l'arborescence de "Dossiers personnels" que j'ai placé devant le chemin de mon calendrier et ça fonctionne !!

ligne que j'ai changé : Set MyEssaiFld = olns.Folders.Item(1).Folders(PCalendrier)

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
Public Function CreerRendezVous(PCalendrier As String, _
 PDate As String, _
 PHeure As String, _
 PDuree As Integer, _
 PSubject As String, _
 PNotes As String, _
 PLieu As String, _
 Optional PMinutesRappel As Integer = 0)
 
On Error GoTo Add_Err
 
Dim objOutlook As Outlook.Application
Dim objAppt As Outlook.AppointmentItem
Dim olns As Outlook.NameSpace
Dim MycalendarFolder As Outlook.MAPIFolder
Dim MyEssaiFld As Outlook.MAPIFolder
Dim MyFolder As Outlook.Items
 
Set objOutlook = CreateObject("Outlook.Application")
Set olns = objOutlook.GetNamespace("MAPI")
Set MycalendarFolder = olns.GetDefaultFolder(olFolderCalendar)
 
'MsgBox MycalendarFolder
 
Set MyEssaiFld = olns.Folders.Item(1).Folders(PCalendrier)
 
'MsgBox MyEssaiFld
'Selectionne le calendrier
If PCalendrier = "" Then
Set MyFolder = MycalendarFolder.Items
Else
Set MyFolder = MyEssaiFld.Items
End If
Set objAppt = MyFolder.Add
'Cree le rendez vous
With objAppt
 
  If PDuree > 0 Then
  .Start = PDate & " " & PHeure
  .Duration = PDuree
  Else
  .Start = PDate
  .AllDayEvent = True
  End If
  .Subject = PSubject
  .Body = PNotes
  .Location = PLieu
  'Ajoute le rappel
  If PMinutesRappel > 0 Then
    .ReminderMinutesBeforeStart = PMinutesRappel
    .ReminderSet = True
  End If
  'Sauvegarde et ferme
  .Save
  .Close (olSave)
End With
'Libération des variables.
Set objAppt = Nothing
Set objOutlook = Nothing
MsgBox "Rdv ajouté!"
Exit Function
'Gere les erreurs
Add_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
End Function

J'ai posté cette réponse en espérant que ça puisse aider quelqu'un comme moi à l'avenir..

Merci en tous cas pour votre site dans lequel j'ai déjà passé des heures, récupéré des dizaines de lignes de code et appris presque tout ce que je sais sur Access...

Chris

[Adeline8]

bonjour,
merci pour cette macro, je m'en suis inspirée et elle fonctionne très bien pour créer des RDV dans un calendrier partagé.
Le seul problème, c'est que quand je lance cette macro, ça m'ouvre à nouveau outlook (déjà ouvert sur mon ordinateur), et dans cette fenetre, seul mon calendrier perso est affiché, alors que le RDV s'enregistre bien dans le calendrier partagé.
J'aimerais que ça n'ouvre plus cette fenetre outlook quand je lance la macro, quelqu'un peut-il m'aider svp ?
(précision : je n'y connais pas grand chose, cette macro a été faite de copier/coller de plusieurs macros que j'ai pu trouver sur les forums, je n'arrive pas à comprendre à quoi correspondent les codes. il y a aura donc certainement des choses en "trop" dans ma macro)

Merci par avance à ceux qui m'aideront

voila le code que j'utilise :

Sub essai_macro_5()
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

Dim OL As Object
Dim OLmail As Object


Set OLk_Appli = CreateObject("Outlook.Application")

If OLk_Appli.Explorers.Count > 0 Then
'Ok outlook ouvert
Else
'mettre le bon chemin outlook
OLk_OK = Shell("C:\Program Files (x86)\Microsoft Office\Office15\outlook.exe", vbHide)
End If

Set OL = New Outlook.Application
Set olns = Outlook.Application.Session
Set objExpCal = olns.GetDefaultFolder(olFolderCalendar).GetExplorer
Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
Set objNavGroup = objNavMod.NavigationGroups.GetDefaultNavigationGroup(olPeopleFoldersGroup)
Set objAppt = Outlook.Application.CreateItem(olAppointmentItem)
If olns.DefaultStore.DisplayName = "richard.XXX@XXXXXX.com" Then
'cas où le propriétaire du calendrier partagé fait l'opération
Set myFolder = olns.GetDefaultFolder(olFolderCalendar)
Set Mysubfolder = myFolder.Folders("SRY Tomato Planning").Items
Else
'cas où un autre utilisateur ayant les droits d'éditeur fait l'opération
Set myRecipient = olns.CreateRecipient("richard.XXX@XXXXXX.com")
myRecipient.Resolve
If myRecipient.Resolved Then
Set Mysubfolder = objNavGroup.NavigationFolders("SRY Tomato Planning").Folder.Items
End If
End If

' Avec la feuille
With Sheets("Feuil1")
DLig = .Range("A" & Rows.Count).End(xlUp).Row
' Pour chaque ligne
For Lig = 2 To DLig
' Si une date existe
If .Range("D" & Lig) <> "" Then
' Si un RDV n'a pas déjà été créé
If .Range("K" & Lig) <> "" Then
' Si le commentaire a changé
If .Range("K" & Lig).Comment.Text <> .Range("H" & Lig).Value Then
FlgRdv = False
Else
' Sinon le commentaire n'a pas changé = pas de RDV
FlgRdv = False
End If
Else
' Sinon, pas de RDV déjà créé
FlgRdv = True
End If
Else
' Sinon, pas de date d'évènement
FlgRdv = False
End If
' Si le FLAG est à vrai on créé le RDV
If FlgRdv Then
DateRdv = Range("D" & Lig)

'Set OutAppt = MyCalendar.Add
'With OutAppt
Set OutAppt = Mysubfolder.Add
With OutAppt
.MeetingStatus = olMeeting
.Subject = Range("E" & Lig) & " - " & Range("F" & Lig) & " - " & Range("B" & Lig) & " - " & Range("D" & Lig)
.Start = Range("D" & Lig) & " 06:00"
.Duration = 60
.ReminderSet = True
.ReminderMinutesBeforeStart = 60 * 24 * Range("I" & Lig)
.Categories = Range("C" & Lig)
.Location = Range("G" & Lig)
.Body = Range("H" & Lig)
.RequiredAttendees = Range("J" & Lig)
.Send
.Save
End With
' Créer le commentaire et inscrire Oui
On Error Resume Next
.Range("K" & Lig).Comment.Delete
.Range("K" & Lig).AddComment
.Range("K" & Lig).Comment.Text Text:=Range("H" & Lig).Value '& Chr(10) & Format(Date, "dd mmmm yyyy")
.Range("K" & Lig) = "Oui"
On Error GoTo 0
End If
Next Lig
End With
Set OutAppt = Nothing




End Sub