Création de rendez-vous Outlook 2016 à partir de Excel2010 [Résolu]

Alethas - 28 déc. 2017 à 22:27 - Dernière réponse : gbinforme 14541 Messages postés lundi 18 octobre 2004Date d'inscriptionContributeurStatut 16 janvier 2018 Dernière intervention
- 16 janv. 2018 à 18:37
Bonjour,

J'utilise un tableau excel pour faire le suivi de plusieurs étapes de la préparation des formations de mon département. Pour en faciliter le suivi j'aimerais pouvoir transférer les dates importantes dans mon calendrier outlook.

En cherchant sur les forums j'ai trouvé un code que je suis parvenue à adapter pour que la bonne information se transfère, mais pour un seul événement. J'aimerais bien que cela puisse se faire pour l'ensemble d'entre eux.

Voici le code que j'ai pour le moment:

#
Sub NouveauRDV_Calendrier()
'Nécessite d'activer la référence "Microsoft Outlook xx.x Object Library"
Dim OkApp As New Outlook.Application
Dim Rdv As Outlook.AppointmentItem

Set Rdv = OkApp.CreateItem(olAppointmentItem)

With Rdv
.MeetingStatus = olMeeting
.Subject = Range("a2")
.Body = "préparer liste de présence et cahiers des participants"
.Location = Range("e2")
.Start = Range("c2")
.Categories = "préparation outils"
.ReminderMinutesBeforeStart = 2880
.AllDayEvent = True
.ReminderSet = True
.Save
End With

Set OkApp = Nothing
End Sub
#

Merci beaucoup de votre aide
A
Afficher la suite 

15 réponses

Répondre au sujet
gbinforme 14541 Messages postés lundi 18 octobre 2004Date d'inscriptionContributeurStatut 16 janvier 2018 Dernière intervention - 2 janv. 2018 à 17:11
+1
Utile
13
Bonjour,

J'aimerais bien que cela puisse se faire pour l'ensemble d'entre eux
comme ceci cela devrait te le permettre :
Sub NouveauRDV_Calendrier()
'Nécessite d'activer la référence "Microsoft Outlook xx.x Object Library"
Dim OkApp As New Outlook.Application
Dim Rdv As Outlook.AppointmentItem
Dim lig As Long
Set Rdv = OkApp.CreateItem(olAppointmentItem)

With Rdv
    For lig = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        .MeetingStatus = olMeeting
        .Subject = Range("A" & lig)
        .Body = "préparer liste de présence et cahiers des participants"
        .Location = Range("E" & lig)
        .Start = Range("C" & lig)
        .Categories = "préparation outils"
        .ReminderMinutesBeforeStart = 2880
        .AllDayEvent = True
        .ReminderSet = True
        .Save
    Next lig
End With

Set OkApp = Nothing
End Sub

gbinforme 14541 Messages postés lundi 18 octobre 2004Date d'inscriptionContributeurStatut 16 janvier 2018 Dernière intervention - 4 janv. 2018 à 21:31
Bonsoir,

une petite possible modification
C'est un peu plus compliqué car il faut tenir compte des jours fériés et donc il te faut les mettre dans une plage au format date que tu devras nommer "fériés".
Ensuite tu remplaces
        .ReminderMinutesBeforeStart = 2880

par
    Dim jrs As Byte, njr As Byte
        jrs = 0: njr = 0
        While njr < 2
           njr = njr + Application.NetworkDays(Range("C" & lig)- jrs, Range("C" & lig)- jrs, Range("fériés"))
           jrs = jrs + 1
        Wend
        .ReminderMinutesBeforeStart = (jrs - 1) * 1440
Alethas 8 Messages postés jeudi 28 décembre 2017Date d'inscription 16 janvier 2018 Dernière intervention - 10 janv. 2018 à 18:05
Bonjour

Merci encore de ton assistance et désolée du délai de réponse.

Lorsque je remplace ma ligne de reminderminutesbeforestart par ton code il me donne un rappel de 1 jour ouvrable calculant les jours fériés, par contre j'aurais une préférence pour 2 jours ouvrables.
Lorsque j'essaie de le modifier, si je change .reminderMinutesBeforeStart en enlevant le -1, il me met l'ensemble à 2 jours ouvrables sauf ceux ou la veille est actuellement une journée ouvrable et à ce moment il me fait simplement 2 jours( rappel des événement du mardi le dimanche sauf si lundi férié, à ce moment là il indique correctement le jeudi)

Je ne sais pas trop qu'est-ce que je pourrais faire pour corriger ceci.

Si tu peux encore m'aider j'apprécierais beaucoup.
gbinforme 14541 Messages postés lundi 18 octobre 2004Date d'inscriptionContributeurStatut 16 janvier 2018 Dernière intervention - 10 janv. 2018 à 18:51
Bonsoir,

Il te suffit de changer ainsi :
While njr < 3
Alethas 8 Messages postés jeudi 28 décembre 2017Date d'inscription 16 janvier 2018 Dernière intervention - 11 janv. 2018 à 14:47
ça semble parfait maintenant, merci.

Je viens de penser par contre en cas de mise à jour, est-ce qu'il y a une façon de l'adapter pour lorsqu'on ajoute des événements par la suite ou qu'on en modifie qu'il ne fasse que les modification sans créer de doublon?

désolée pour toutes ces modifications

edit: ou qu'il efface les doublons?
Alethas 8 Messages postés jeudi 28 décembre 2017Date d'inscription 16 janvier 2018 Dernière intervention - 16 janv. 2018 à 16:59
Rebonjour,

je relance. Est-ce que ce serait possible d'adapter ce code pour qu'il s'applique à tous les changements lorsque ajoute un événement sans avoir à le repasser au complet et donc créer des doublons de chaque événement pré-existant.

Je donne le code de où on en est rendu.

Sub NouveauRDV_Calendrier()
'Nécessite d'activer la référence "Microsoft Outlook xx.x Object Library"
Dim OkApp As New Outlook.Application
Dim Rdv As Outlook.AppointmentItem
Dim lig As Long
For lig = 2 To Cells(Rows.Count, 1).End(xlUp).Row
Set Rdv = OkApp.CreateItem(olAppointmentItem)
With Rdv
.MeetingStatus = olNonMeeting
.Subject = Range("A" & lig)
.Body = "préparer liste de présence et cahiers des participants"
.BusyStatus = olFree
.Location = Range("F" & lig) & " " & Range("G" & lig)
.Start = Range("C" & lig) + Range("D" & lig)
.End = Range("C" & lig) + Range("E" & lig)
.Categories = "Date de formation"
Dim jrs As Byte, njr As Byte
jrs = 0: njr = 0
While njr < 3
njr = njr + Application.NetworkDays(Range("C" & lig) - jrs, Range("C" & lig) - jrs, Range("fériés"))
jrs = jrs + 1
Wend
.ReminderMinutesBeforeStart = (jrs - 1) * 1440
.ReminderSet = True
.Save
.Close (olSave)
End With
Set Rdv = Nothing
Next lig
Set OkApp = Nothing
End Sub


merci à l'avance de toute votre aide
Commenter la réponse de gbinforme
gbinforme 14541 Messages postés lundi 18 octobre 2004Date d'inscriptionContributeurStatut 16 janvier 2018 Dernière intervention - 16 janv. 2018 à 18:37
0
Utile
Bonjour,

sans avoir à le repasser au complet et donc créer des doublons
Pour cela, je te propose de mémoriser le transfert en colonne G.
Si tu l'utilises pour autre chose tu mets une colonne libre.
Option Explicit

Sub NouveauRDV_Calendrier()
'Nécessite d'activer la référence "Microsoft Outlook xx.x Object Library"
Dim OkApp As New Outlook.Application
Dim Rdv As Outlook.AppointmentItem
Dim jrs As Byte, njr As Byte
Dim lig As Long, nbt As Integer
Set Rdv = OkApp.CreateItem(olAppointmentItem)

With Rdv
    For lig = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        If Range("G" & lig).Value = "" Then
            .MeetingStatus = olMeeting
            .Subject = Range("A" & lig)
            .Body = "préparer liste de présence et cahiers des participants"
            .Location = Range("E" & lig)
            .Start = Range("C" & lig)
            .Categories = "préparation outils"
            jrs = 0: njr = 0
            While njr < 3
               njr = njr + Application.NetworkDays(Range("C" & lig) - jrs, Range("C" & lig) - jrs, Range("fériés"))
               jrs = jrs + 1
            Wend
            .ReminderMinutesBeforeStart = (jrs - 1) * 1440
            .AllDayEvent = True
            .ReminderSet = True
            .Save
            nbt = nbt + 1
            Range("G" & lig).Value = "Enregistré" ' la colonne G mémorise les transferts
        End If
    Next lig
End With
If nbt Then MsgBox nbt & " transferts"
Set OkApp = Nothing
End Sub

Commenter la réponse de gbinforme