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
| Private Sub Worksheet_Change(ByVal Target As Range)
Dim MaDate As Range
Const olAppointmentItem As Long = 1
Dim OLApp As Object
Dim OLNS As Object
Dim OLAppointment As Object
Set MaDate = Range("D1:D100")
If Not Application.Intersect(MaDate, Range(Target.Address)) _
Is Nothing Then
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 = "Relance client"
OLAppointment.Start = Target.Value & " 09:00 "
OLAppointment.Body = Target.Offset(0, -2).Value & " " + Target.Offset(0, 6).Value & " " + Target.Offset(0, 7).Value & " " + Target.Offset(0, 1).Value & " "
OLAppointment.Save
Set OLAppointment = Nothing
Set OLNS = Nothing
Set OLApp = Nothing
End If
End If
End Sub |
Partager