Problème VBA et Outlook

Bonjour,

Je vous écris car j'ai fait une automatisation qui permet d'enregistrer automatiquement des rendez-vous dans Outlook à partir d'un tableau Excel.

1 ) J'ai un premier problème sur l'heure de mes rendez-vous, je n'arrive pas à paramétrer l'heure pour "Start", du coup tous mes rdv sont bookés par défaut à minuit... Voilà mon code :

Code:

---

1 2 3 4 5 6 7 8 9 10 11

Set oAppointment = DossierCalendrier.Items.Add     With oAppointment .MeetingStatus = olNonMeeting .Subject = "Profile reactivation for user " & Cell.Offset(0, -7) & " " & Cell.Offset(0, -6) & " " & Cell.Offset(0, -5) .Body = "Change Status - ""Out"" to ""Active""" .Start = CDate(Cell.Offset(0, -2)) .Duration = 30 .Save End With

---

Peu importe l'heure de la journée à laquelle le rdv car ce sont en fait des rappels d'une tâche à faire, mais il faut quand même que ce soit dans les horaires de travail...
J'ai essayé sans succès quelaue chose comme :

Code:

---

Start = CDate(Cell.Offset(0, -2)) & "09:00:00"

---

2) Je n'arrive pas à choisir un autre calendrier que mon calendrier personnel. Je voudrais enregistrer ces rdv dans un calendrier commun, partagé entre 3 personnes.

En utilisant le calendrier par défaut, cela fontionne bien :

Code:

---

1 2	Set ns = ol.GetNamespace("MAPI") 'Reference the default Calendar folder Set fdCalendar = ns.GetDefaultFolder(olFolderCalendar)

---

J'ai essayé de recopier bêtement la fonction que quelqu'un avait fait sur le net, permettant de choisir son calendrier, mais peut-être que je l'ai mal placée, mal adaptée, rien ne se passe en tous cas :

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

Sub ListerRépertoires()   Dim MyNameSpace, Folder, SubFolder Dim strTemp As String   On Error GoTo Erreur   Set objOutlook = New Outlook.Application Set MyNameSpace = objOutlook.GetNamespace("MAPI")   'Lister les répertoires principaux For Each Folder In MyNameSpace.Folders strTemp = strTemp & Folder.Name & vbCrLf strTemp = strTemp & GetSubFolder(Folder) 'recherche des sous-répertoires Next Set MyNameSpace = Nothing Set objOutlook = Nothing MsgBox strTemp Exit Sub   Erreur: MsgBox Err.Description   End Sub     Function GetSubFolder(Folder) As String   Dim strTemp As String   Dim FolderTemp       For Each FolderTemp In Folder.Folders   If FolderTemp.DefaultItemType = olAppointmentItem Then 'type Calendrier   strTemp = strTemp & vbTab & FolderTemp.Name & vbCrLf   End If   Next       GetSubFolder = strTemp   End Function

---

C'est peut-être une problématique bête, mais je n'y arrive pas !

Merci d'avance de votre aide,