Appel de macro pour rendez vous sous outlook

Le 12/10/2017 à 16:07

Bonjour a tous et merci de prendre quelques minutes pour m'aider.

Je vous expose mon problème. Je suis en train de crée une base de donné client comprenant les informations de mon client ainsi que des rappel de rendez vous a prendre.

Pour faire simple j'ai dans une colonnes A la liste de mes client et dans une colonne B les dates de rappels . Je souhaiterais que lorsque je saisie une date de rappel cela lance une macro pour me crée un rendez vous sous outlook à la date saisie pour le client de la ligne concerné par la saisie, j'ai essayé une macro qui regroupe plusieurs macro trouver sur le net mais je suis perdu. je suis plus que novice et vous sollicite . Merci d'avance

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column = 2 And Target.Value <> "" Then

Set OlApp = CreateObject("Outlook.application")

Set NS = OlApp.GetNamespace("MAPI")

Set m = OlApp.CreateItem(olAppointmentItem)

With m

.Subject = "Relance client"

.Body = " client a relancer " & "date"

End With

End If

End Sub

Le 12/10/2017 à 20:56

Bonjour ksimir72,

voici le code, à placer dans le module de la feuille source:

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("B1:B20") '=========>> Plage à adapter <<=======

    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
        OLAppointment.Body = Target.Offset(0, -1).Value & " " & Target.Value
        OLAppointment.Save
        Set OLAppointment = Nothing
        Set OLNS = Nothing
        Set OLApp = Nothing        
    End If
End If

End Sub

Le 13/10/2017 à 08:48

Je vous remercie énormément pour cette réponse ça marche super bien, néanmoins il me met le rendez vous a minuit dans mon agenda, est il possible de fixer l'heure du rendez vous a 9h ?

Merci d'avance

Le 13/10/2017 à 09:36

Bonjour j'ai réussi a mettre l’horaire a 9 h en faisant ça mais il me coole des rappel de rendez vous depuis l'année 1899 bizarre comme bug????? pouvez vous m'aider? merci d'avance

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.Value

OLAppointment.Save

Set OLAppointment = Nothing

Set OLNS = Nothing

Set OLApp = Nothing

End If

c'est encore moi ... es ce du aux cellules vide? peut etre qu'il faut lancer la macro que si la cellule est rempli ?

Le 13/10/2017 à 19:29

Salut ksimir72,

vois si ça te convient:

OLAppointment.Start = Target.Value + TimeValue("09:00")

Le 16/10/2017 à 10:23

Merci pour votre réponse néanmoins j'ai toujours mon problème de rendez vous depuis 1899, il prend en compte les cellules vides et me créé des rendez vous .. avez vous une solution? une boucle de test de cellule vide?

Le 16/10/2017 à 16:57

Bonjour ksimir72,

Merci de joindre un fichier exemple (sans données confidentielles).

Le 17/10/2017 à 17:09