Liste de date Excel vers calendrier outlook

Bonjour le forum,

J'utilise le code ci dessous pour créer des RDV Outlook à partir d'excel.

Je cherche à modifier le code afin de pouvoir créer une liste de RDV automatiquement à partir des dates de la plage H3:H102, mais là je sèche...

J'ai mis le fichier en pièce jointe.

Merci pour toute aide,

Vincent

Sub Appointments()
Const olAppointmentItem As Long = 1
Dim OLApp As Object
Dim OLNS As Object
Dim OLAppointment As Object

On Error Resume Next
Set OLApp = GetObject(, "Outlook.Application")
If OLApp Is Nothing Then Set OLApp = CreateObject("Outlook.Application")
On Error GoTo 0

If Not OLApp Is Nothing Then

Set OLNS = OLApp.GetNamespace("MAPI")
OLNS.Logon

Set OLAppointment = OLApp.CreateItem(olAppointmentItem)
OLAppointment.Subject = "Anniversaire" & "colonne B" & "colonne C" & "colonne D"
OLAppointment.Body = "Anniversaire" & "colonne B" & "colonne C" & "colonne D"
OLAppointment.Start = "colonne H mais pas si jour =0"
OLAppointment.Duration = 60
OLAppointment.ReminderMinutesBeforeStart = 30
OLAppointment.Save

Set OLAppointment = Nothing
Set OLNS = Nothing
Set OLApp = Nothing
End If

End Sub

bonsoir,

une proposition, non testée.

Sub Appointments()
Const olAppointmentItem As Long = 1
Dim OLApp As Object
Dim OLNS As Object
Dim OLAppointment As Object

On Error Resume Next
Set OLApp = GetObject(, "Outlook.Application")
If OLApp Is Nothing Then Set OLApp = CreateObject("Outlook.Application")
On Error GoTo 0

If Not OLApp Is Nothing Then

Set OLNS = OLApp.GetNamespace("MAPI")
OLNS.Logon
for i=3 to 102
if range("h" & i) <>0 then
Set OLAppointment = OLApp.CreateItem(olAppointmentItem)
OLAppointment.Subject = "Anniversaire" & range("B" & i) & range("c" & i) & range("d" & i)
OLAppointment.Body = "Anniversaire" & range("B" & i) & range("c" & i) & range("d" & i)
OLAppointment.Start = range("h" & i)
OLAppointment.Duration = 60
OLAppointment.ReminderMinutesBeforeStart = 30
OLAppointment.Save

Set OLAppointment = Nothing
end if
next i

Set OLNS = Nothing
Set OLApp = Nothing
End If

End Sub

Bonjour,

Merci ! Le code fonctionne parfaitement.

j'ai voulu faire une modif avec deux possibilités, mais elles ne marchent pas l'une comme l'autre:

1)

For i = 3 To 102

If Range("i" & i) <> "" And Range("i" & i) > Now Then

ou 2)

 For i = 3 To 102

If Range("i" & i) > Now Then

Les Rdv s'inscrivent dans outook même si les dates sont avant aujourd'hui... je ne comprends pas, probablement un lien avec les formats date et VBA ?

Merci pour toute idée,

Vincent

les dates d'anniversaire ne contiennent généralement pas l'année. est-ce le cas dans ton fichier ?

Bonjour,

J'ai bien l'année (2013) pour les dates anniversaires. Donc je ne vois pas le souci...

J'aurai une autre question : comment modifier le code pour créer un RDV à partir de la ligne sélectionnée ?

Merci pout ton aide,

Vincent

vincentt a écrit :

Bonjour,

J'ai bien l'année (2013) pour les dates anniversaires. Donc je ne vois pas le souci...

alors je pense qu'il doit y avoir un problème avec le format de date. Peut-être la date n'est-elle pas reconnue comme une date.

es-tu sûr que la date est en colonne H ?

tu peux envoyer un extrait de ton fichier (anonymisé), pour comprendre quel est ce problème de date ?

J'aurai une autre question : comment modifier le code pour créer un RDV à partir de la ligne sélectionnée ?

Merci pout ton aide,

Vincent

voici le code adapté, à tester

Sub Appointments()
Const olAppointmentItem As Long = 1
Dim OLApp As Object
Dim OLNS As Object
Dim OLAppointment As Object

On Error Resume Next
Set OLApp = GetObject(, "Outlook.Application")
If OLApp Is Nothing Then Set OLApp = CreateObject("Outlook.Application")
On Error GoTo 0

If Not OLApp Is Nothing Then

Set OLNS = OLApp.GetNamespace("MAPI")
OLNS.Logon
' créer des rendez-vous pour les lignes sélectionnées.
for each r in selection.rows
i=r.row
if range("h" & i) <>0 then
Set OLAppointment = OLApp.CreateItem(olAppointmentItem)
OLAppointment.Subject = "Anniversaire" & range("B" & i) & range("c" & i) & range("d" & i)
OLAppointment.Body = "Anniversaire" & range("B" & i) & range("c" & i) & range("d" & i)
OLAppointment.Start = range("h" & i)
OLAppointment.Duration = 60
OLAppointment.ReminderMinutesBeforeStart = 30
OLAppointment.Save

Set OLAppointment = Nothing
end if
next 

Set OLNS = Nothing
Set OLApp = Nothing
End If

End Sub