Créer un événement Outlook à partir d'Excel

Le 21/02/2020 à 11:31

Bonjour à tous,

Je suis novice dans VBA, et je souhaite mettre en place un système qui permettra de créer des rendez-vous Outlook à partir d'un tableau excel qui me sert à suivre ma sous-traitance. J'ai réussi à avancer en lisant différentes aides sur internet et prendre des morceaux de VBA que j'ai adapté à mon cas. Mon point bloquant actuel, est que je n'arrive pas à lui faire écrire ces rendez-vous dans le calendrier compte2 qui est une adresse mail active sur plusieurs postes (ci-dessous l'image des calendriers).

Pour autant, j'arrive à lui faire lire le calendrier voulu (compte2) mais il écrit quand même dans le compte1. Pourriez-vous svp m'aider à me débloquer sur ce point ?

Pour précision dans ce code : Set Fld = getDefaultFolderFromUser("compte2", olFolderCalendar) (vous verrez dans le code joint je marque l'adresse complète dans cette ligne de code mais j'ai pas le droit de le faire temps que je n'ai pas écrit 10 messages dans ce forum.) je mets une vrai adresse active dans mon fichier ce qui génère un message dans excel comme suit :

Je vous mets en pièce jointe également le fichier excel et ci-dessous le fichier texte du code que j'ai adapté.

203code-suivi-sous-traitance-test.txt (2.05 Ko)

Merci pour l'attention que vous porterez à ma demande. En espérant avoir été clair dans ma demande.

David

177suivi-sous-traitance-test.xlsm (32.63 Ko)

Le 02/03/2020 à 11:31

Bonjour,

Est-ce que quelqu'un saurez me répondre à ce sujet svp ?

Cdlt

David

Le 02/03/2020 à 13:47

Bonjour,

Essayer ce code

Sub NouveauRDV_Calendrier()

    Dim OkApp As New Outlook.Application
    Dim Rdv As Outlook.AppointmentItem
    Dim Fld As Outlook.MAPIFolder

    For i = 7 To Cells(Rows.Count, 12).End(xlUp).Row
        Set Fld = getDefaultFolderFromUser("compte2@compte2.com", olFolderCalendar)
        Set Rdv = Fld.Items.Add(olAppointmentItem)
        With Rdv
            .MeetingStatus = olMeeting
            .Subject = "Relance commande " + Cells(i, 1).Value
            .Body = "Supplier : " & Cells(i, 3).Value & Chr(13) & "Mail : " & Cells(i, 4).Value & Chr(13) & "Phone : " & Cells(i, 5).Value & Chr(13) & "Description : " & Cells(i, 6).Value & Chr(13) & "PN : " & Cells(i, 7).Value & Chr(13) & "QTY : " & Cells(i, 10).Value & Chr(13) & Chr(13) & "Order Date : " & Cells(i, 2).Value & Chr(13) & "Date PN Requested : " & Cells(i, 12).Value & Chr(13) & "Project Deadline : " & Cells(i, 11).Value & Chr(13) & "Acknowledgementof Receipt : " & Cells(i, 13).Value
            .Location = "Supplier : " & Cells(i, 3).Value
            .Start = Range("l" & i).Value - 7 & " 09:00"
            .Duration = 30 'minutes
            .Save
        End With
    Next

    Set OkApp = Nothing

End Sub

Le 03/03/2020 à 14:08

Bonjour Thev,

Merci pour ce code il fonctionne parfaitement. Auriez-vous une idée pour dire à excel de ne pas s'occuper des lignes déjà traitées ? car il me créé un nouveau RDV à chaque fois que je lance le VBA !

Cordialement,

David

Le 03/03/2020 à 17:40

David03 a écrit :
Auriez-vous une idée pour dire à excel de ne pas s'occuper des lignes déjà traitées ? car il me créé un nouveau RDV à chaque fois que je lance le VBA !

Vous créez un RV 7 jours avant votre Date PN Requested. Ce RV ne peut être inscrit que selon un certain délai à définir par rapport à la date du jour. Donc un test entre votre Date PN Requested et la date du jour en fonction d'un certain délai devrait conditionner vos lignes.

Le 04/03/2020 à 16:39

thev a écrit :
David03 a écrit :
Auriez-vous une idée pour dire à excel de ne pas s'occuper des lignes déjà traitées ? car il me créé un nouveau RDV à chaque fois que je lance le VBA !
Vous créez un RV 7 jours avant votre Date PN Requested. Ce RV ne peut être inscrit que selon un certain délai à définir par rapport à la date du jour. Donc un test entre votre Date PN Requested et la date du jour en fonction d'un certain délai devrait conditionner vos lignes.

Bonjour,

Merci pour la réponse, mais qu'est-ce que vous appelez un test et comment vous le formulez dans VBA ?

Cordialement,

David

Le 04/03/2020 à 18:50

Bonjour,

ci-dessous exemple de test.

Vos lignes ne génèreront une relance qui si leur Date PN Requested est supérieure à la date du jour d'au moins 7 jours

 Sub NouveauRDV_Calendrier()

    Dim OkApp As New Outlook.Application
    Dim Rdv As Outlook.AppointmentItem
    Dim Fld As Outlook.MAPIFolder

    For i = 7 To Cells(Rows.Count, "L").End(xlUp).Row
        If Cells(i, "L") > Date + 7 Then
            Set Fld = getDefaultFolderFromUser("compte2@compte2.com", olFolderCalendar)
            Set Rdv = Fld.Items.Add(olAppointmentItem)
            With Rdv
                .MeetingStatus = olMeeting
                .Subject = "Relance commande " + Cells(i, "A").Value
                .Body = "Supplier : " & Cells(i, "C").Value & Chr(13)
                .Body = .Body & "Mail : " & Cells(i, "D").Value & Chr(13)
                .Body = .Body & "Phone : " & Cells(i, "E").Value & Chr(13)
                .Body = .Body & "Description : " & Cells(i, "F").Value & Chr(13)
                .Body = .Body & "PN : " & Cells(i, "G").Value & Chr(13)
                .Body = .Body & "QTY : " & Cells(i, "J").Value & Chr(13) & Chr(13)
                .Body = .Body & "Order Date : " & Cells(i, "B").Value & Chr(13)
                .Body = .Body & "Date PN Requested : " & Cells(i, "L").Value & Chr(13)
                .Body = .Body & "Project Deadline : " & Cells(i, "K").Value & Chr(13)
                .Body = .Body & "Acknowledgementof Receipt : " & Cells(i, "M").Value
                .Location = "Supplier : " & Cells(i, "C").Value
                .Start = Cells(i, "L").Value - 7 & " 09:00"
                .Duration = 30 'minutes
                .Save
            End With
        End If
    Next

    Set OkApp = Nothing

End Sub

Le 05/03/2020 à 11:54

thev a écrit :

Bonjour,

ci-dessous exemple de test.

Vos lignes ne génèreront une relance qui si leur Date PN Requested est supérieure à la date du jour d'au moins 7 jours

 Sub NouveauRDV_Calendrier()

    Dim OkApp As New Outlook.Application
    Dim Rdv As Outlook.AppointmentItem
    Dim Fld As Outlook.MAPIFolder

    For i = 7 To Cells(Rows.Count, "L").End(xlUp).Row
        If Cells(i, "L") > Date + 7 Then
            Set Fld = getDefaultFolderFromUser("compte2compte2", olFolderCalendar)
            Set Rdv = Fld.Items.Add(olAppointmentItem)
            With Rdv
                .MeetingStatus = olMeeting
                .Subject = "Relance commande " + Cells(i, "A").Value
                .Body = "Supplier : " & Cells(i, "C").Value & Chr(13)
                .Body = .Body & "Mail : " & Cells(i, "D").Value & Chr(13)
                .Body = .Body & "Phone : " & Cells(i, "E").Value & Chr(13)
                .Body = .Body & "Description : " & Cells(i, "F").Value & Chr(13)
                .Body = .Body & "PN : " & Cells(i, "G").Value & Chr(13)
                .Body = .Body & "QTY : " & Cells(i, "J").Value & Chr(13) & Chr(13)
                .Body = .Body & "Order Date : " & Cells(i, "B").Value & Chr(13)
                .Body = .Body & "Date PN Requested : " & Cells(i, "L").Value & Chr(13)
                .Body = .Body & "Project Deadline : " & Cells(i, "K").Value & Chr(13)
                .Body = .Body & "Acknowledgementof Receipt : " & Cells(i, "M").Value
                .Location = "Supplier : " & Cells(i, "C").Value
                .Start = Cells(i, "L").Value - 7 & " 09:00"
                .Duration = 30 'minutes
                .Save
            End With
        End If
    Next

    Set OkApp = Nothing

End Sub

Bonjour Thev,

Cela fonctionne effectivement pour les dates antérieures, mais si par exemple je remplie une ligne avec un date PN requested au 20/03/2020, je lance le VBA cela me place mon rdv au 13/03/2020 et que dans un second temps je rajoute encore une nouvelle ligne avec une date PN requested au 30/03/2020 et que je lance le VBA, il me place un rdv au 23/03/2020 (normal) mais il me replace un rdv pour la ligne à la date PN requested du 20/03/2020 au 13/03/2020 du coup ça fait doublon à chaque délai à j+7.

J'espère que je me fais comprendre

Merci encore,

David

Le 05/03/2020 à 17:19

Bonjour,

Dans ce cas, une solution est d'insérer dans la cellule contenant la date PN Requested, un commentaire indiquant la date de relance.

La relance n'est alors effectuée que si aucun commentaire n'est présent dans cette cellule.

ci-dessous exemple de code :

Sub NouveauRDV_Calendrier()

    Dim OkApp As New Outlook.Application
    Dim Rdv As Outlook.AppointmentItem
    Dim Fld As Outlook.MAPIFolder

    For i = 7 To Cells(Rows.Count, "L").End(xlUp).Row
        If Cells(i, "L") > Date + 7 _
        And Cells(i, "L").Comment Is Nothing Then

            '-- détermination dossier calendrier associé au compte
            Set Fld = getDefaultFolderFromUser("compte2@compte2.com", olFolderCalendar)

            '-- génération RDV  dans le calendrier associé au compte
            Set Rdv = Fld.Items.Add(olAppointmentItem)
            With Rdv
                .MeetingStatus = olMeeting
                .Subject = "Relance commande " + Cells(i, "A").Value
                .Body = "Supplier : " & Cells(i, "C").Value & Chr(13)
                .Body = .Body & "Mail : " & Cells(i, "D").Value & Chr(13)
                .Body = .Body & "Phone : " & Cells(i, "E").Value & Chr(13)
                .Body = .Body & "Description : " & Cells(i, "F").Value & Chr(13)
                .Body = .Body & "PN : " & Cells(i, "G").Value & Chr(13)
                .Body = .Body & "QTY : " & Cells(i, "J").Value & Chr(13) & Chr(13)
                .Body = .Body & "Order Date : " & Cells(i, "B").Value & Chr(13)
                .Body = .Body & "Date PN Requested : " & Cells(i, "L").Value & Chr(13)
                .Body = .Body & "Project Deadline : " & Cells(i, "K").Value & Chr(13)
                .Body = .Body & "Acknowledgementof Receipt : " & Cells(i, "M").Value
                .Location = "Supplier : " & Cells(i, "C").Value
                .Start = Cells(i, "L").Value - 7 & " 09:00"
                .Duration = 30 'minutes
                .Save
            End With

            '-- ajout commentaire date de relance
            Cells(i, "L").AddComment "relance envoyée le " & Date
        End If
    Next

    Set OkApp = Nothing

End Sub

Le 06/03/2020 à 14:42

thev a écrit :

Bonjour,

Dans ce cas, une solution est d'insérer dans la cellule contenant la date PN Requested, un commentaire indiquant la date de relance.

La relance n'est alors effectuée que si aucun commentaire n'est présent dans cette cellule.

ci-dessous exemple de code :

Sub NouveauRDV_Calendrier()

    Dim OkApp As New Outlook.Application
    Dim Rdv As Outlook.AppointmentItem
    Dim Fld As Outlook.MAPIFolder

    For i = 7 To Cells(Rows.Count, "L").End(xlUp).Row
        If Cells(i, "L") > Date + 7 _
        And Cells(i, "L").Comment Is Nothing Then

            '-- détermination dossier calendrier associé au compte
            Set Fld = getDefaultFolderFromUser("compte2acompte2com", olFolderCalendar)

            '-- génération RDV  dans le calendrier associé au compte
            Set Rdv = Fld.Items.Add(olAppointmentItem)
            With Rdv
                .MeetingStatus = olMeeting
                .Subject = "Relance commande " + Cells(i, "A").Value
                .Body = "Supplier : " & Cells(i, "C").Value & Chr(13)
                .Body = .Body & "Mail : " & Cells(i, "D").Value & Chr(13)
                .Body = .Body & "Phone : " & Cells(i, "E").Value & Chr(13)
                .Body = .Body & "Description : " & Cells(i, "F").Value & Chr(13)
                .Body = .Body & "PN : " & Cells(i, "G").Value & Chr(13)
                .Body = .Body & "QTY : " & Cells(i, "J").Value & Chr(13) & Chr(13)
                .Body = .Body & "Order Date : " & Cells(i, "B").Value & Chr(13)
                .Body = .Body & "Date PN Requested : " & Cells(i, "L").Value & Chr(13)
                .Body = .Body & "Project Deadline : " & Cells(i, "K").Value & Chr(13)
                .Body = .Body & "Acknowledgementof Receipt : " & Cells(i, "M").Value
                .Location = "Supplier : " & Cells(i, "C").Value
                .Start = Cells(i, "L").Value - 7 & " 09:00"
                .Duration = 30 'minutes
                .Save
            End With

            '-- ajout commentaire date de relance
            Cells(i, "L").AddComment "relance envoyée le " & Date
        End If
    Next

    Set OkApp = Nothing

End Sub

Bonjour Thev,

Super, vraiment c'est nickel comme solution. Je te remercie.

Puis-je abusé encore un peu car du coup une amélioration pourrait parfaire mon tableau. Je m'explique, la colonne L (Date PN Requested) est la date que moi je demande mais parfois le fournisseur répond que c'est trop juste et qu'il lui faut 1 semaine de plus par exemple. D'où la colonne M (Acknowledgment of receipt) qui la date accusé par le fournisseur. Dans ce cas, peut-on dire au vba de prioriser la date de la colonne M pour la date de relance dans outlook et si la cellule est vide (dans le cas d'une non réponse du fournisseur) prendre la date de la colonne L ?

Et pour aller encore plus loin, disons que je lance le programme vba, car je viens de rentrer une nouvelle commande à la date du 30/03/2020, et que quelques jours plus tard j'ai la réponse du fournisseur pour le 15/04/2020 que je rempli donc dans la colonne M. Pourrait'on demander au vba de supprimer le rdv créé par la colonne L et de réaliser celui par la colonne M ?

Merci encore,

Cordialement,

David

Le 07/03/2020 à 20:58

Bonsoir,

Pour répondre à vos demandes, ci-dessous proposition de code

Sub NouveauRDV_Calendrier()

    Dim OkApp As New Outlook.Application
    Dim Rdv As Outlook.AppointmentItem
    Dim Fld As Outlook.MAPIFolder
    Dim Date_receipt As Range
    Dim no_PO As String

    For i = 7 To Cells(Rows.Count, "L").End(xlUp).Row

        '-- affectation de la date de réception
        Set Date_receipt = Cells(i, "L")
        If Cells(i, "M") <> Empty Then Set Date_receipt = Cells(i, "M")

        '-- génération d'une relance selon conditions
        If IsDate(Date_receipt.Value) _
        And Date_receipt.Value > Date + 7 _
        And Date_receipt.Comment Is Nothing Then

            '-- détermination dossier calendrier associ? au compte
            Set Fld = getDefaultFolderFromUser("compte2@compte2.com", olFolderCalendar)

            '-- génération RDV  dans le calendrier associé au compte
            Set Rdv = Fld.Items.Add(olAppointmentItem)
            no_PO = Cells(i, "A").Value
            Call supp_rdv_existant(Fld, no_PO)

            With Rdv
                .MeetingStatus = olMeeting
                .Subject = "Relance commande " & no_PO
                .RequiredAttendees = no_PO
                .Body = "Supplier : " & Cells(i, "C").Value & Chr(13)
                .Body = .Body & "Mail : " & Cells(i, "D").Value & Chr(13)
                .Body = .Body & "Phone : " & Cells(i, "E").Value & Chr(13)
                .Body = .Body & "Description : " & Cells(i, "F").Value & Chr(13)
                .Body = .Body & "PN : " & Cells(i, "G").Value & Chr(13)
                .Body = .Body & "QTY : " & Cells(i, "J").Value & Chr(13) & Chr(13)
                .Body = .Body & "Order Date : " & Cells(i, "B").Value & Chr(13)
                .Body = .Body & "Date PN Requested : " & Cells(i, "L").Value & Chr(13)
                .Body = .Body & "Project Deadline : " & Cells(i, "K").Value & Chr(13)
                .Body = .Body & "Acknowledgementof Receipt : " & Cells(i, "M").Value
                .Location = "Supplier : " & Cells(i, "C").Value
                .Start = Date_receipt.Value - 7 & " 09:00"
                .Duration = 30 'minutes
                .Save
            End With

            '-- ajout commentaire date de relance
            Date_receipt.AddComment "relance envoy?e le " & Date
        End If
    Next

    Set OkApp = Nothing

End Sub

Sub supp_rdv_existant(calendrier, no_cde)
     Dim Rdv As Outlook.AppointmentItem

     For Each Rdv In calendrier.Items
        If Rdv.RequiredAttendees = no_cde Then Rdv.Delete
     Next Rdv

End Sub

End Sub

Le 10/03/2020 à 16:57

Bonjour Thev,

Je te remercie de ta réponse Thev. Malheureusement cela ne fonctionne pas. A priori si je lance le programme, il ne prends pas en compte la date indiqué en colonne M mais en Colonne L lorsque que les deux colonnes sont remplis. Par contre il met bien le commentaire sur la colonne M si une date est renseigné. De même si je supprime les commentaires et les rdv dans outlook et que je relance le programme, il ne créé pas les même rdv à chaque fois alors que je ne modifie pas les dates entre chaque essai, et de plus, oublie des lignes. J'ai essayé en enlevant les parties concernant le no-Po :

Dim no_PO As String

no_PO = Cells(i, "A").Value

Call supp_rdv_existant(Fld, no_PO)

Sub supp_rdv_existant(calendrier, no_cde)

Dim Rdv As Outlook.AppointmentItem

For Each Rdv In calendrier.Items

If Rdv.RequiredAttendees = no_cde Then Rdv.Delete

Next Rdv

End Sub

et cela à l'air d'être plus stable. Mais je n'obtiens pas l'objectif donné que je demandais dans mon précédent message.

Je vous remets le fichier excel et le code que vous avez fait pour que vous puissiez vois ce que j'explique.

Je vous remercie de m'éclaircir et de voir comment on peut améliorer ça. Perso je essayé pleins de choses mais je ne comprends pas ce qui se passe.

Cordialement,

David

60suivi-sous-traitance-test.xlsm (32.51 Ko)

31code-suivi-sous-traitance-test.txt (3.14 Ko)

Le 12/03/2020 à 13:27

Bonjour,

Je n'avais pas transmis la dernière version.

rectification à apporter :

        
         With Rdv
            .MeetingStatus = olMeeting
            .Subject = "Relance commande " & no_PO
            .RequiredAttendees = no_PO
            .Body = "Supplier : " & Cells(i, "C").Value & Chr(13)
            .Body = .Body & "Mail : " & Cells(i, "D").Value & Chr(13)
            .Body = .Body & "Phone : " & Cells(i, "E").Value & Chr(13)
            .Body = .Body & "Description : " & Cells(i, "F").Value & Chr(13)
            .Body = .Body & "PN : " & Cells(i, "G").Value & Chr(13)
            .Body = .Body & "QTY : " & Cells(i, "J").Value & Chr(13) & Chr(13)
            .Body = .Body & "Order Date : " & Cells(i, "B").Value & Chr(13)
            .Body = .Body & "Date PN Requested : " & Cells(i, "L").Value & Chr(13)
            .Body = .Body & "Project Deadline : " & Cells(i, "K").Value & Chr(13)
            .Body = .Body & "Acknowledgementof Receipt : " & Cells(i, "M").Value
            .Location = "Supplier : " & Cells(i, "C").Value
            .Start = Date_receipt.Value - 7 & " 09:00"
            .Duration = 30 'minutes
            .Save
        End With

Le 18/03/2020 à 11:47

Bonjour Thev,

Je suis navré de répondre si tard, mais au vue des circonstances national il a fallu s'occuper d'autre priorité et je ne peux pour le moment pas tester tout ça. Toutefois je vous remercie de votre réponse et des que les choses redeviendront normal je testerai votre programme.

Cordialement

David

Rechercher des sujets similaires à "creer evenement outlook partir"