Discussion :

[Toro74]

Bonjour à tous.
A partir d'un fichier Excel où l'on saisi des dates pour des échéances, des évènements réunions sont automatiquement créés.
Ce que je souhaiterais, c'est si la date est modifiée que la réunion crée précédemment soit annulée.
Voici mon code de création qui fonctionne parfaitement :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
36
37
38
If Not Intersect(Target, Range("C187")) Is Nothing Then
        choix = MsgBox("Confirmez-vous la date du " & Range("C187") & " pour cette échéance? Un évènement sera créé à cette date dans votre calendrier ", 36, "Confirmation")
            'Si l'utilisateur a cliqué sur le bouton Oui
            If choix = vbYes Then
            Dim objOL
          Dim objAppt
          Const olAppointmentItem = 1
          Const olMeeting = 1
          Set objOL = CreateObject("Outlook.Application")
          Set objAppt = objOL.CreateItem(olMeeting)
          With objAppt
            .Subject = "Date limite engagement des dépenses financement Etat " & Range("E177") & " Projet " & Range("C5")
            .Body = "Ceci est un évènement généré lors de la saisie"
            .Start = Range("C187")
            .AllDayEvent = True
            .BusyStatus = olFree
            .Categories = "Echéance Automatique "
            .ReminderSet = True
            .ReminderMinutesBeforeStart = 21600
            .Importance = olImportanceHigh
            .Location = "CCVT"
            .MeetingStatus = olMeeting
            'participant optionnel
            .OptionalAttendees = ADDRESSEDUGEST
            'participant obligatoire
            .RequiredAttendees = Range("E9")
            .send
            End With
          Set objAppt = Nothing
          Set objOL = Nothing
        End If
        If choix = vbNo Then
            Range("C187") = ""
            Range("C187").Select
        End If
    End If
 
End If

Est-ce que vous auriez des idées pour m'aider ?
Bonne journée

[umfred]

Je suppose que ton code est dans Worksheet_Change(Target as Range)
Donc ton problème peut se résumer à connaitre la valeur précédent la modification pour vérifier et supprimer le RDV prévu à la date précédente (la seconde partie de ton problème sera de trouver et supprimer cette réunion)

Dans les codes courants pour connaitre la valeur précédente on trouve ça:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
Dim oldValue As Variant
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    oldValue = Target.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    'do something with oldValue...
End Sub

oldvalue devant être une variable globale
(d'autres façons sont décrites dans ce forum https://stackoverflow.com/questions/...l-in-excel-vba )

Pour le trouver, regarder du côté de https://learn.microsoft.com/en-us/of...ppointmentitem et sa méthode Delete pour la supprimer

[Toro74]

Bonjour,
J'ai testé ce code sur la base de oldvalue, il fonctionne pour la création mais ne marche pas non plus pour l'annulation, je pense que c'est parce qu'il ne recherche pas la bonne date, pourriez vous m'aider? :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
Private Sub Worksheet_Change(ByVal Target As Range)
 
   On Error Resume Next
    If olApp Is Nothing Then
        Set olApp = New Outlook.Application
    End If
    On Error GoTo 0
 
    ' Vérifier si la cellule D187 a été modifiée
    If Not Intersect(Target, Me.Range("D187")) Is Nothing Then
        HandleDateChange Target, "Date limite engagement des dépenses financement Etat " & Range("E177") & " Projet " & Range("C5")
    End If
End Sub
Option Explicit
 
Private olApp As Outlook.Application
Private oldValue As Variant ' Variable pour stocker l'ancienne valeur de la cellule
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' Enregistrer l'ancienne valeur de la cellule dans la variable globale oldValue
    oldValue = Target.Value
End Sub
Private Sub HandleDateChange(ByVal Target As Range, ByVal objCell As String)
    Dim newDate As Date
    newDate = Target.Value
 
    ' Vérifier si la cellule contient une date (n'est pas vide)
    If IsDate(newDate) Then
        ' Vérifier si la cellule avait déjà une date
        If Not IsEmpty(oldValue) Then
            ' La cellule avait déjà une date, demander confirmation pour la modification
            If MsgBox("Confirmez-vous la modification de la date du " & oldValue & " pour cette échéance? L'échéance sera automatiquement modifiée dans votre agenda.", vbYesNo + vbQuestion, "Confirmation") = vbYes Then
                ' Supprimer l'événement dans Outlook existant
                DeleteOutlookAppointment oldValue, objCell
                ' Créer une nouvelle réunion dans Outlook avec la nouvelle date et l'objet
                CreateOutlookAppointment newDate, objCell
            Else
                ' L'utilisateur a choisi "Non" dans le message de confirmation
                ' Vous pouvez ajouter ici des actions supplémentaires à effectuer si l'utilisateur n'a pas confirmé la modification de la date.
                ' Par exemple, vous pouvez rétablir la date précédente dans la cellule.
                Application.EnableEvents = False
                Target.Value = oldValue
                Application.EnableEvents = True
            End If
        Else
            ' La cellule était vide (pas de date précédente), demander confirmation pour la création de l'événement
            If MsgBox("Confirmez-vous la date du " & newDate & " pour cette échéance? Un événement sera créé à cette date dans votre calendrier.", vbYesNo + vbQuestion, "Confirmation") = vbYes Then
                ' Créer une nouvelle réunion dans Outlook avec la date et l'objet spécifiés
                CreateOutlookAppointment newDate, objCell
            Else
                ' L'utilisateur a choisi "Non" dans le message de confirmation
                ' Vous pouvez ajouter ici des actions supplémentaires à effectuer si l'utilisateur n'a pas confirmé la date.
                ' Par exemple, vous pouvez vider la cellule.
                Application.EnableEvents = False
                Target.ClearContents
                Application.EnableEvents = True
            End If
        End If
    Else
        ' La cellule ne contient pas une date (est vide)
        ' Vous pouvez ajouter ici des actions à effectuer si la cellule est vidée ou si une date est effacée.
    End If
End Sub
 
Private Sub CreateOutlookAppointment(ByVal newDate As Date, ByVal objCell As String)
    On Error Resume Next
    If olApp Is Nothing Then
        Set olApp = New Outlook.Application
    End If
    On Error GoTo 0
 
    Dim olNamespace As Outlook.Namespace
    Set olNamespace = olApp.GetNamespace("MAPI")
    Dim olCalendar As Outlook.Folder
    Set olCalendar = olNamespace.GetDefaultFolder(olFolderCalendar)
    Dim olAppointment As Outlook.AppointmentItem
    Set olAppointment = olApp.CreateItem(olAppointmentItem)
 
    ' Définir les propriétés de l'événement
    With olAppointment
        .Start = newDate
        .Subject = objCell
        .Location = "Emplacement de la réunion" ' Remplacez par l'emplacement souhaité
        .Body = "Description de la réunion" ' Remplacez par la description souhaitée
        .ReminderSet = True ' Définir un rappel pour l'événement (true) ou non (false)
        .ReminderMinutesBeforeStart = 15 ' Définir le temps du rappel en minutes avant le début de l'événement
        .MeetingStatus = olMeeting ' Cela marque l'événement comme une réunion
        .RequiredAttendees = "adresse-email-invite@exemple.com" ' Remplacez par l'adresse e-mail de l'invité
        ' Ajoutez d'autres propriétés ou modifiez celles-ci en fonction de vos besoins
    End With
 
    ' Enregistrer l'événement dans le calendrier et envoyer l'invitation
    olAppointment.Save
    olAppointment.Send
End Sub
 
Private Sub DeleteOutlookAppointment(ByVal oldDate As Date, ByVal objCell As String)
    On Error Resume Next
    If olApp Is Nothing Then
        Set olApp = New Outlook.Application
    End If
    On Error GoTo 0
 
    Dim olNamespace As Outlook.Namespace
    Set olNamespace = olApp.GetNamespace("MAPI")
    Dim olCalendar As Outlook.Folder
    Set olCalendar = olNamespace.GetDefaultFolder(olFolderCalendar)
    Dim olItems As Outlook.Items
    Set olItems = olCalendar.Items
 
    ' Filtrer les éléments du calendrier correspondant à l'ancienne date et à l'objet spécifique
    Dim strFilter As String
    strFilter = "[Start] >= '" & DateValue(oldDate) & "' AND [Start] < '" & DateValue(oldDate + 1) & "' AND [Subject] = '" & objCell & "'"
    Dim olFilteredItems As Outlook.Items
    Set olFilteredItems = olItems.Restrict(strFilter)
 
    ' Variable pour indiquer si l'événement a été trouvé et supprimé
    Dim eventFound As Boolean
    eventFound = False
 
    ' Supprimer tous les éléments filtrés (si plusieurs événements trouvés)
    Dim i As Long
    For i = olFilteredItems.Count To 1 Step -1
        Dim olAppt As Outlook.AppointmentItem
        Set olAppt = olFilteredItems.Item(i)
 
        If olAppt.Class = olAppointment Then
            ' Afficher des informations pour débogage
            Debug.Print "Événement trouvé à la date : " & olAppt.Start & ", Objet : " & olAppt.Subject
            ' Marquer la réunion comme annulée (Cancellation)
            olAppt.MeetingStatus = olMeetingCanceled
            olAppt.Save
            ' Envoyer une notification d'annulation à tous les invités
            olAppt.Send
            eventFound = True
        End If
    Next i
 
    ' Afficher un message si l'événement n'a pas été trouvé
    If Not eventFound Then
        MsgBox "L'événement pour la date " & Format(oldDate, "dd/mm/yyyy") & " et l'objet " & objCell & " n'a pas été trouvé dans votre calendrier.", vbExclamation, "Aucun événement trouvé"
    End If
End Sub
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    ' Code pour fermer l'application Outlook
    If Not olApp Is Nothing Then
        olApp.Quit
        Set olApp = Nothing
    End If
End Sub

[laurent_ott]

...je pense que c'est parce qu'il ne recherche pas la bonne date...

Peut-être une piste, je n'ai jamais fait ce genre de chose mais d'après la documentation https://learn.microsoft.com/fr-fr/of...items.restrict

Date
Bien que les dates et heures soient généralement stockées dans un format Date, les méthodes Find et Restrict nécessitent que la date et l’heure soient converties en une représentation sous forme de chaîne. Pour vérifier que la date est mise en forme comme prévu dans Microsoft Outlook, utilisez la fonction Format. L’exemple suivant crée un filtre pour trouver tous les contacts qui ont été modifiées après le 15 janvier 1999 à 3:30 P.M.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

sFilter = "[LastModificationTime] > '" & Format("1/15/99 3:30pm", "ddddd h:nn AMPM") & "'"

[umfred]

faire du pas à pas dans ta fonction de suppression et vérifier les valeurs retournées à chaque étape pour voir où se cache le loup (après correction du code)

[Toro74]

Merci pour vos retours,
Le code fonctionne ainsi :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
 
Private oldValue As Variant
Private olApp As Outlook.Application
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    Set rng = Me.Range("C187") ' Remplacez "C187" par l'adresse de la cellule que vous souhaitez surveiller
 
    ' Vérifier si le changement a été effectué dans la cellule spécifiée
    If Not Intersect(Target, rng) Is Nothing Then
        ' Vérifier si la cellule contient une date
        If IsDate(rng.Value) Then
            ' Vérifier si la valeur de la cellule a été modifiée et si la valeur initiale n'est pas vide
            If Target.Value <> oldValue And oldValue <> Empty Then
                ' Afficher le message de confirmation avant de créer l'événement dans Outlook
                If MsgBox("Confirmez-vous la modification de la date du " & oldValue & " pour cette échéance? L'échéance sera automatiquement modifiée dans votre agenda.", vbYesNo + vbQuestion, "Confirmation") = vbYes Then
                    ' Supprimer la réunion dans Outlook existante (si nécessaire)
                    DeleteOutlookAppointment
 
                    ' Créer une nouvelle réunion dans Outlook
                    CreateOutlookAppointment Target.Value
                Else
                    ' L'utilisateur a choisi "Non" dans le message de confirmation
                    ' Vous pouvez ajouter ici des actions supplémentaires à effectuer si l'utilisateur n'a pas confirmé la modification de la date.
                    ' Par exemple, vous pouvez rétablir la date précédente dans la cellule.
                    Application.EnableEvents = False
                    rng.Value = oldValue
                    Application.EnableEvents = True
                End If
            End If
        Else
            ' La cellule ne contient pas une date (est vide)
            ' Afficher le message de confirmation avant de créer l'événement dans Outlook
            If MsgBox("Confirmez-vous la date du " & rng.Value & " pour cette échéance? Un événement sera créé à cette date dans votre calendrier.", vbYesNo + vbQuestion, "Confirmation") = vbYes Then
                ' Créer une nouvelle réunion dans Outlook avec copie à une autre personne
 
                CreateOutlookAppointment Target.Value
            Else
                ' L'utilisateur a choisi "Non" dans le message de confirmation
                ' Vous pouvez ajouter ici des actions supplémentaires à effectuer si l'utilisateur n'a pas confirmé la date.
                ' Par exemple, vous pouvez vider la cellule.
                Application.EnableEvents = False
                rng.ClearContents
                Application.EnableEvents = True
            End If
        End If
    End If
 
    ' Stocker la nouvelle valeur dans la variable oldValue
    oldValue = Target.Value
End Sub
 
Private Sub DeleteOutlookAppointment()
    On Error Resume Next
    If olApp Is Nothing Then
        Set olApp = New Outlook.Application
    End If
    On Error GoTo 0
 
    Dim olNamespace As Outlook.Namespace
    Set olNamespace = olApp.GetNamespace("MAPI")
    Dim olAppointment As Outlook.AppointmentItem
    Set olAppointment = olNamespace.GetDefaultFolder(olFolderCalendar).Items.Find("[Subject] = 'Réunion'") ' Remplacez "Réunion" par le sujet de votre réunion
    If Not olAppointment Is Nothing Then
        olAppointment.Delete
    End If
End Sub
 
Private Sub CreateOutlookAppointment(ByVal newDate As Date)
Dim ADDRESSEDUGEST As String
'Evenement calendrier financement Etat 1
ADDRESSEDUGEST = "BLABLA@BLA.BLA"
    On Error Resume Next
    If olApp Is Nothing Then
        Set olApp = New Outlook.Application
    End If
    On Error GoTo 0
 
    Dim olNamespace As Outlook.Namespace
    Set olNamespace = olApp.GetNamespace("MAPI")
    Dim olAppointment As Outlook.AppointmentItem
    Set olAppointment = olApp.CreateItem(olAppointmentItem)
    With olAppointment
        .Start = newDate
        .End = newDate
        .AllDayEvent = True
        .subject = "Réunion"
        .Location = "Lieu de la réunion"
        .Body = "Description de la réunion"
        .Recipients.Add Range("E9")
        .Recipients.Add ADDRESSEDUGEST
        .MeetingStatus = olMeeting
        .Send
    End With
End Sub
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If Not olApp Is Nothing Then
        olApp.Quit
        Set olApp = Nothing
    End If
End Sub

Le soucis c'est que j'ai 70 cellules concernées, y aurait il un moyen pour réduire la procédure change en précisant uniquement la date et l'objet de ces 70 cellules ?