Créer un rendez-vous dans OUTLOOK

Salut J-Pierre

Voilà l'article de la KB pour créer un RDV

http://support.microsoft.com/kb/209963/fr

Suffit de l'adapter pour gérer les MAJ et suppressions

J-Pierre


"J-Pierre" <pas.de.pub.jpberchtold@hotmail.com> a écrit dans le message de news: u9$2IiMKGHA.360@TK2MSFTNGP12.phx.gbl...

Bonjour tout le monde,

Tout est dans le titre, une recherche m'a permis de trouver facilement sur le site de Pierre le code pour lire le contenu du
calendrier, mais pas pour y écrire (création de nouveaux RDV ou MAJ des existants. Alors, si vous avez un bout de code qui
m'évitera de me battre avec le modèle d'objet, ce serait très gentil.

Autre possibilité, utiliser les tables liées, ce serait encore plus simple, mais pour certains, il semble que cela pose des
problèmes de performance. Qu'en est-il exactement ?

Merci
J-Pierre

Bonjour tout le monde,

En mélangeant harmonieusement le code de Pierre et celui de la KB, j'ai 3 routines VBA pour la création, la modification et la
suppression de RDV dans Outlook. Parce que, avec les tables liées, impossible de faire quelque chose d'intéressant, les
informations les plus importantes ne sont pas disponibles.

Est-ce que ça vous intéresse ? Sinon, pas la peine que je me fatigue à publier......

J-Pierre

Salut,

"J-Pierre"

| Est-ce que ça vous intéresse ? Sinon, pas la peine que je me fatigue à publier......


Si tu veux, je l'ajouterai au reste ;-)


--
A+
Pierre (3stone) Access MVP
Perso: http://www.3stone.be/
Conseils MPFA: http://www.mpfa.info/

Ca roule, Pierre, voilà le code, et je précise que tu peux l'ajouter "au reste" si TU veux.......et TU modifies tout ce que TU
veux.

Dans le code, j'utilise une fonction "Format" pour éviter les différences possibles entre le format des dates Access et
Outlook et peut-être les options régionales. Je ne sais pas si ça sert à grand-chose, mais ça me parait plus sûr.
Je n'utilise pas non plus les fonctions/propriétés qui font appel aux contacts pour éviter l'ouverture de la boîte de dialogue
"Une application essaie etc....."

Une dernière remarque: Le code pour supprimer/modifier un RDV ne fonctionne pas s'il se trouve dans l'évènement "sur
chargement" d'un formulaire (le RDV n'est pas trouvé dans la collection d'Outlook), mais fonctionne s'il se trouve dans
l'évènement "sur activation".

J-Pierre

________________________
CREER UN RENDEZ-VOUS (Quelques propriétés que je n'utilise pas en commentaires)
________________________

On Error GoTo Outlook_Add_Err

Dim objOutlook As Outlook.Application
Dim objAppt As Outlook.AppointmentItem
Dim objRecurPattern As Outlook.RecurrencePattern

Set objOutlook = CreateObject("Outlook.Application")
Set objAppt = objOutlook.CreateItem(olAppointmentItem)

With objAppt
.Start = Me.MonChampDate & " " & Me.MonChampHeure
.Duration = Clng(Me.MonChampDuree)
.Subject = Me.MonChampSujet
.ReminderMinutesBeforeStart = 60
.ReminderSet = True

' If Not IsNull(Me!ApptNotes) Then .Body = Me!ApptNotes
' If Not IsNull(Me!ApptLocation) Then .Location = Me!ApptLocation

'Rendez-vous récurrent une fois par semaine, du 9 au 23 juillet 2005
' Set objRecurPattern = .GetRecurrencePattern
' With objRecurPattern
' .RecurrenceType = olRecursWeekly
' .Interval = 1
' .PatternStartDate = #7/9/2005#
' .PatternEndDate = #7/23/2005#
' End With

.Save
.Close (olSave)

End With

Set objAppt = Nothing
Set objOutlook = Nothing

Outlook_Add_Exit:

DoCmd.Close acForm, Me.Name
Exit Sub

Outlook_Add_Err:

MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Set objOutlook = Nothing
Set objAppt = Nothing
Resume Outlook_Add_Exit

____________________________
SUPPRIMER UN RENDEZ-VOUS
____________________________

Sub DeleteOutlook()

Dim dateDeb As String, dateFin As String, Sujet As String, Duree As Long
Dim Trouve As Boolean, Wresponse As String

'-----------------------------------------------------------------------
' Préparer les critères de recherche pour la suppression
'-----------------------------------------------------------------------

Sujet = Me.MonChampSujet
dateDeb = Format(Me.MonChampDate & " " & Me.MonChampHeure, "dd/mm/yy hh:nn:ss")
dateFin = Format(DateAdd("n", Me.MonChampDuree, dateDeb), "dd/mm/yy hh:nn:ss")
Duree = Me.MonChampDuree

'-----------------------------------------------------------------------
' Supprimer le RDV dans Outlook
'-----------------------------------------------------------------------
On Error GoTo DeleteOutlook_Err

Dim Ol_App As New Outlook.Application
Dim Ol_Mapi As Outlook.NameSpace
Dim Ol_Folder As Outlook.MAPIFolder
Dim Ol_Items As Outlook.Items
Dim Ol_Appointment As Outlook.AppointmentItem

Set Ol_App = CreateObject("Outlook.Application")
Set Ol_Mapi = Ol_App.GetNamespace("MAPI")
Set Ol_Folder = Ol_Mapi.GetDefaultFolder(olFolderCalendar)
Set Ol_Items = Ol_Folder.Items

Trouve = False

For Each Ol_Appointment In Ol_Items
' MsgBox "DB Sujet RDV =" & Sujet & "=" & vbCrLf & _
' "DB Date début RDV =" & dateDeb & "=" & vbCrLf & _
' "DB Date fin RDV =" & dateFin & "=" & vbCrLf & _
' "DB Durée RDV =" & Duree & "=" & vbCrLf & vbCrLf & _
' "OL Sujet RDV =" & Ol_Appointment.Subject & "=" & vbCrLf & _
' "OL Date début RDV =" & Format(Ol_Appointment.Start, "dd/mm/yy hh:nn:ss") & "=" & vbCrLf & _
' "OL Date fin RDV =" & Format(Ol_Appointment.End, "dd/mm/yy hh:nn:ss") & "=" & vbCrLf & _
' "OL Durée RDV =" & Ol_Appointment.Duration & "="
If Ol_Appointment.Subject = Sujet _
And Format(Ol_Appointment.Start, "dd/mm/yy hh:nn:ss") = dateDeb _
And Format(Ol_Appointment.End, "dd/mm/yy hh:nn:ss") = dateFin _
And Ol_Appointment.Duration = Duree Then
Trouve = True
Wresponse = MsgBox("Voulez vous supprimer ce rendez-vous du calendrier Outlook ?" & _
vbCrLf & vbCrLf & _
"Sujet RDV : " & Ol_Appointment.Subject & vbCrLf & _
"Date début RDV : " & Format(Ol_Appointment.Start, "dd/mm/yy hh:nn:ss") & vbCrLf & _
"Date fin RDV : " & Format(Ol_Appointment.End, "dd/mm/yy hh:nn:ss") & vbCrLf & _
"Durée RDV : " & Ol_Appointment.Duration & " minutes", _
vbYesNo + vbQuestion, "SUPPRESSION D'UN RENDEZ-VOUS OUTLOOK")
If Wresponse = vbYes Then
Ol_Appointment.Delete
End If
End If
Next Ol_Appointment

Set Ol_Appointment = Nothing
Set Ol_Items = Nothing
Set Ol_Folder = Nothing
Set Ol_Mapi = Nothing
Set Ol_App = Nothing

On Error GoTo 0

If Trouve = False Then
MsgBox "Ce rendez-vous n'a pas été trouvé dans le calendrier Outlook", _
vbOKOnly, "SUPPRESSION D'UN RENDEZ-VOUS OUTLOOK"
End If

DeleteOutlook_Exit:

Exit Sub

DeleteOutlook_Err:

MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Set Ol_Appointment = Nothing
Set Ol_Items = Nothing
Set Ol_Folder = Nothing
Set Ol_Mapi = Nothing
Set Ol_App = Nothing
Resume DeleteOutlook_Exit

End Sub

___________________________
MODIFIER UN RENDEZ-VOUS
___________________________

Sub ModifyOutlook(NewDate As Date, NewHeure As String, NewDuree As Long, NewRappel As Boolean)

Dim dateDeb As String, dateFin As String, Sujet As String, Duree As Long
Dim Trouve As Boolean, Wresponse As String

'-----------------------------------------------------------------------
' Préparer les critères de recherche pour la modification
'-----------------------------------------------------------------------

Sujet = "???????????????"
dateDeb = Format(Me.MonChampDate & " " & Me.MonChampHeure, "dd/mm/yy hh:nn:ss")
dateFin = Format(DateAdd("n", Me.MonChampDuree, dateDeb), "dd/mm/yy hh:nn:ss")
Duree = Me.MonChampDuree

'-----------------------------------------------------------------------
' Modifier le RDV dans Outlook
'-----------------------------------------------------------------------
On Error GoTo ModifyOutlookOutlook_Err

Dim Ol_App As New Outlook.Application
Dim Ol_Mapi As Outlook.NameSpace
Dim Ol_Folder As Outlook.MAPIFolder
Dim Ol_Items As Outlook.Items
Dim Ol_Appointment As Outlook.AppointmentItem

Set Ol_App = CreateObject("Outlook.Application")
Set Ol_Mapi = Ol_App.GetNamespace("MAPI")
Set Ol_Folder = Ol_Mapi.GetDefaultFolder(olFolderCalendar)
Set Ol_Items = Ol_Folder.Items

Trouve = False

For Each Ol_Appointment In Ol_Items
' MsgBox "DB Sujet RDV =" & Sujet & "=" & vbCrLf & _
' "DB Date début RDV =" & dateDeb & "=" & vbCrLf & _
' "DB Date fin RDV =" & dateFin & "=" & vbCrLf & _
' "DB Durée RDV =" & Duree & "=" & vbCrLf & vbCrLf & _
' "OL Sujet RDV =" & Ol_Appointment.Subject & "=" & vbCrLf & _
' "OL Date début RDV =" & Format(Ol_Appointment.Start, "dd/mm/yy hh:nn:ss") & "=" & vbCrLf & _
' "OL Date fin RDV =" & Format(Ol_Appointment.End, "dd/mm/yy hh:nn:ss") & "=" & vbCrLf & _
' "OL Durée RDV =" & Ol_Appointment.Duration & "="
If Ol_Appointment.Subject = Sujet _
And Format(Ol_Appointment.Start, "dd/mm/yy hh:nn:ss") = dateDeb _
And Format(Ol_Appointment.End, "dd/mm/yy hh:nn:ss") = dateFin _
And Ol_Appointment.Duration = Duree Then
Trouve = True
Wresponse = MsgBox("Voulez vous modifier ce rendez-vous du calendrier Outlook ?" & _
vbCrLf & vbCrLf & _
"Sujet RDV : " & Ol_Appointment.Subject & vbCrLf & _
"Date début RDV : " & Format(Ol_Appointment.Start, "dd/mm/yy hh:nn:ss") & vbCrLf & _
"Date fin RDV : " & Format(Ol_Appointment.End, "dd/mm/yy hh:nn:ss") & vbCrLf & _
"Durée RDV : " & Ol_Appointment.Duration & " minutes", _
vbYesNo + vbQuestion, "MODIFICATION D'UN RENDEZ-VOUS OUTLOOK")
If Wresponse = vbYes Then
Ol_Appointment.Start = NewDate & " " & NewHeure
Ol_Appointment.Duration = NewDuree
Ol_Appointment.ReminderSet = NewRappel
Ol_Appointment.Save
End If
End If
Next Ol_Appointment

Set Ol_Appointment = Nothing
Set Ol_Items = Nothing
Set Ol_Folder = Nothing
Set Ol_Mapi = Nothing
Set Ol_App = Nothing

On Error GoTo 0

If Trouve = False Then
MsgBox "Ce rendez-vous n'a pas été trouvé dans le calendrier Outlook", _
vbOKOnly, "MODIFICATION D'UN RENDEZ-VOUS OUTLOOK"
End If

ModifyOutlookOutlook_Exit:

Exit Sub

ModifyOutlookOutlook_Err:

MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Set Ol_Appointment = Nothing
Set Ol_Items = Nothing
Set Ol_Folder = Nothing
Set Ol_Mapi = Nothing
Set Ol_App = Nothing
Resume ModifyOutlookOutlook_Exit

Salut,

"J-Pierre"
| Ca roule, Pierre, voilà le code...


Ok merci !


--
A+
Pierre (3stone) Access MVP
Perso: http://www.3stone.be/
Conseils MPFA: http://www.mpfa.info/