Suppression Réunion Outlook suite à modification de date sur fichier Excel

Version imprimable

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:

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

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:

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

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:

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

27/07/2023, 16h28
laurent_ott

Citation:

Envoyé par Toro74

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

sFilter = "[LastModificationTime] > '" & Format("1/15/99 3:30pm", "ddddd h:nn AMPM") & "'"
27/07/2023, 17h20
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)

Merci pour vos retours,
Le code fonctionne ainsi :

Code:

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 ?

27/07/2023, 18h40
umfred

j'ai du mal à comprendre la question.
ton code réagit si tu modifies la cellule C187 (grâce au premier test et la définition de rng)
Si tu veux qu'il réagisse à la modification d'autres cellules, il faut modifier la valeur de cette variable rng
avec Set rng=Range("C1:C255") ça exécutera ton code si une des cellules entre C1 et C255 est modifiée.
28/07/2023, 14h30
Toro74

Le problème c'est que pour chaque évènement à créer le subject est différent.
28/07/2023, 15h45
umfred

et ? tu dois savoir à un moment le nom du sujet correspondant, non ?
Il faut organiser les infos pour que tu puisses déterminer l'événement à créer à un moment donné du code.

Tu procèdes comment actuellement ?
28/07/2023, 15h50
Toro74

J'ai 70 codes agenda dans un module à part (l'un est écrit sur le premier post), avec à chaque fois un "subject" différent. Et j'ai mis un code de déclenchement appelant l'une de ces procédures sil y a un changement sur la cellule date qui y est rattachée, j'ai du découper en différente sub car le code était trop long pour une procédure change. Et cela ne gère que la création pas la suppression. Donc si je dois tous écrire dans la procédure change le code sera trop long.
28/07/2023, 17h02
umfred

Citation:

Envoyé par Toro74

Et j'ai mis un code de déclenchement appelant l'une de ces procédures sil y a un changement sur la cellule date qui y est rattachée

Comment est fait cette étape ???
parce que le code de base reste le même, il faut "juste" modifier ce qu'il y a à modifier par rapport au type d'événement, donc il doit être possible de faire "une seule" fonction dans laquelle on passerait les bonnes infos par rapport au déclenchement.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
If Not Intersect(Target, Range("C187")) Is Nothing Then
Call agenda1
End If
 
If Not Intersect(Target, Range("D187")) Is Nothing Then
Call agenda2
End If
 
If Not Intersect(Target, Range("G187")) Is Nothing Then
Call agenda3
End If
 
If Not Intersect(Target, Range("C190")) Is Nothing Then
Call agenda4
End If

Ect

Code:

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
Sub agenda1
If Range("C187") <> "" 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 blabla " & Range("E177") & " Projet " & Range("C5")
            .Body = "blabla"
            .Start = Range("C187")
            .AllDayEvent = True
            .BusyStatus = olFree
            .Categories = "blabla"
            .ReminderSet = True
            .ReminderMinutesBeforeStart = 21600
            .Importance = olImportanceHigh
            .Location = "CCVT"
 
            .MeetingStatus = olMeetingCanceled '
            '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 Sub

et qu'est ce qui change entre agenda1 et agenda2 (ou les autres?)

dans l'idée, c'est d'avoir des tableaux ou collections qui listent les écarts et qu'on appelle une unique fonction en passant les bons paramètres

Par exemple avec un dictionnaire (il faut ajouter la référence Microsoft Scripting Runtime dans les références du VBA)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
 
public mondict as new Scripting.Dictionnary
 
Sub InitDict()
    Dim cle as string, valeur as string
    Set mondict = new Scripting.Dictionnary ' on réinitialise le dictionnaire au début de la fonction
    cle = "agenda1"
    valeur=Param1_agenda1 & ";" & Param2_agenda1 & ";" & Param3_agenda1 ' ......
    mondict.add cle,valeur 
    cle = "agenda2"
    valeur=Param1_agenda2 & ";" & Param2_agenda2 & ";" & Param3_agenda2
 [...]
End Sub

on peut imaginer:

que param1_agendax est la cellule correspondante à agendax ("C187" donc pour agenda1)
que param2_agendax est le texte du sujet (ici ça pourrait être "Date limite blabla XXXXX Projet YYYYY"
que param3_agendax est la cellule de l'emplacement de XXXXX
que param4_agendax est la cellule de l'emplacement de YYYYY
....

On appelle ensuite la fonction call agenda(mondict("agenda1"))

Code:

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
 
sub agenda(paramstr as string)
    Dim paramarray
   paramarray=split(paramstr,";") ' on sépare la chaine des paramètres selon les points-virgules (ça implique que les paramètres ne peuvent pas contenir de points virgules (on peut changer le séparateur si nécessaire)
If Range(paramarray(0)) <> "" Then
        choix = MsgBox("Confirmez-vous la date du " & Range(paramarray(0)) & " 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 = replace(replace(paramarray(1),"XXXXX",range(paramarray(2))),"YYYYY",Range(paramarray(3)))
            .Body = paramarray(4)
            .Start = Range(paramarray(0))
            .AllDayEvent = True
            .BusyStatus = olFree
            .Categories = paramarray(5)
            .ReminderSet = True
            .ReminderMinutesBeforeStart = 21600 ' si varie, mettre le paramarray correspondant
            .Importance = olImportanceHigh
            .Location = "CCVT" ' si varie, mettre le paramarray correspondant
 
            .MeetingStatus = olMeetingCanceled '
            'participant optionnel
            .OptionalAttendees = ADDRESSEDUGEST ' si varie, mettre le paramarray correspondant
            'participant obligatoire
            .RequiredAttendees = Range("E9") ' si varie, mettre le paramarray correspondant
            .Send
            End With
          Set objAppt = Nothing
          Set objOL = Nothing
        End If
        If choix = vbNo Then
            Range(paramarray(0)) = ""
            Range(paramarray(0)).Select
        End If
    End If
end Sub

ça reste perfectible, on peut passer des collections ou des tableaux ou encore, on peut passer les bons paramètres à chaque fois; ça évitera d'avoir 70 fois (ou plus) le même code (par contre là, on garde les 70 appels, mais ça doit pouvoir s'optimiser aussi d'une façon similaire)

Il n'y a que la date et l'objet qui change entre agenda 1 et 2 ect,
ta proposition pourrait simplifier le code initial oui, merci.
Ca peut se combiner avec la version prenant en compte le changement de date?

Code:

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

28/07/2023, 18h20
umfred

Je ne vois pas ce qui peut l'empêcher à partir du moment où tu fournis les bonnes infos aux fonctions

Pour "Dim paramarray" erreur de compilation :attendu identificateur

Code:

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
Public mondict As New Scripting.Dictionary
Public oldValue As Variant ' Ajouter cette ligne pour stocker l'ancienne valeur de la cellule
 
Sub InitDict()
    Dim cle As String, valeur As String
    Set mondict = New Scripting.Dictionary ' on réinitialise le dictionnaire au début de la fonction
 
    ' Définir les clés (agenda1, agenda2, etc.) et leurs valeurs (paramètres)
    cle = "agenda1"
    valeur = "C187;Date limite engagement des dépenses financement Etat XXXXX Projet YYYYY;C190;C191;Description de la réunion;Catégorie1;BLABLA@BLA.BLA"
    mondict.Add cle, valeur
 
    cle = "agenda2"
    valeur = "D187;Date limite approbation dépenses financement Etat ZZZZZ Projet WWWW;D190;D191;Description de la réunion;Catégorie2;BLABLA2@BLA.BLA"
    mondict.Add cle, valeur
 
    ' Ajouter d'autres clés et valeurs pour les autres cellules à surveiller
End Sub
 
Sub Workbook_Open()
    InitDict ' Appeler la fonction pour initialiser le dictionnaire au démarrage du classeur
End Sub
 
Sub Agenda(paramstr As String)
    Dim paramArray
    paramArray = Split(paramstr, ";") ' on sépare la chaine des paramètres selon les points-virgules (ça implique que les paramètres ne peuvent pas contenir de points-virgules)
 
    If Range(paramArray(0)) <> "" Then
        Dim choix As VbMsgBoxResult
        choix = MsgBox("Confirmez-vous la date du " & Range(paramArray(0)) & " pour cette échéance? Un événement sera créé à cette date dans votre calendrier ", vbYesNo + vbQuestion, "Confirmation")
 
        If choix = vbYes Then
            Dim objOL
            Dim objAppt
            Const olAppointmentItem = 1
            Const olMeeting = 1
            Set objOL = CreateObject("Outlook.Application")
            Set objAppt = objOL.CreateItem(olAppointmentItem)
 
            With objAppt
                .Start = Range(paramArray(0))
                .End = Range(paramArray(0))
                .AllDayEvent = True
                .subject = Replace(Replace(paramArray(1), "XXXXX", Range(paramArray(2))), "YYYYY", Range(paramArray(3)))
                .Body = paramArray(4)
                .BusyStatus = olFree
                .Categories = paramArray(5)
                .ReminderSet = True
                .ReminderMinutesBeforeStart = 21600 ' si varie, mettre le paramarray correspondant
                .Importance = olImportanceHigh
                .Location = "lieu" ' si varie, mettre le paramarray correspondant
                .MeetingStatus = olMeetingCanceled
                'participant optionnel
                .OptionalAttendees = paramArray(7) ' si varie, mettre le paramarray correspondant
                'participant obligatoire
                .RequiredAttendees = paramArray(6) ' si varie, mettre le paramarray correspondant
                .Send
            End With
 
            Set objAppt = Nothing
            Set objOL = Nothing
        End If
 
        If choix = vbNo Then
            Range(paramArray(0)) = ""
            Range(paramArray(0)).Select
        End If
    End If
End Sub
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngC187 As Range, rngD187 As Range ' Ajouter d'autres objets pour les autres cellules à surveiller
    Dim paramArray As Variant
    Dim agendaKey As String
    Dim oldValueDate As Date ' Ajouter cette variable pour stocker l'ancienne date
 
    Set rngC187 = Me.Range("C187") ' Remplacez "C187" par l'adresse de la cellule C187
    Set rngD187 = Me.Range("D187") ' Remplacez "D187" par l'adresse de la cellule D187
    ' Ajouter d'autres objets pour les autres cellules à surveiller
 
    ' Vérifier si le changement a été effectué dans l'une des cellules spécifiées
    If Not Intersect(Target, Union(rngC187, rngD187)) Is Nothing Then
        If IsDate(Target.Value) Then
            ' Vérifier quelle cellule a été modifiée
            If Target.Address = rngC187.Address Then
                agendaKey = "agenda1"
            ElseIf Target.Address = rngD187.Address Then
                agendaKey = "agenda2"
            ' Ajouter d'autres conditions pour les autres cellules si nécessaire
            End If
 
            ' Récupérer les paramètres pour cette cellule
            paramArray = Split(mondict(agendaKey), ";")
 
            ' Supprimer l'événement précédent avant de créer le nouvel événement
            If Not IsEmpty(oldValueDate) Then
                DeleteOutlookAppointment Range(paramArray(0)), oldValueDate
            End If
 
            ' Stocker la nouvelle date pour une utilisation future
            oldValueDate = Target.Value
 
            ' Appeler la fonction Agenda pour créer le nouvel événement
            Agenda mondict(agendaKey)
        End If
    End If
End Sub
 
Private Sub DeleteOutlookAppointment(ByVal dateCell As Range, ByVal oldDate As Date)
    On Error Resume Next
    Dim objOL
    Dim objNamespace
    Dim objAppt As Object
    Dim objFolder As Object
 
    Set objOL = CreateObject("Outlook.Application")
    Set objNamespace = objOL.GetNamespace("MAPI")
    Set objFolder = objNamespace.GetDefaultFolder(9) 'olFolderCalendar = 9
 
    ' Boucler sur tous les éléments du dossier Outlook pour trouver l'événement à supprimer
    For Each objAppt In objFolder.Items
        If objAppt.Class = 26 And objAppt.subject = "Réunion" And objAppt.Start = oldDate Then 'olAppointment = 26
            objAppt.Delete
            Exit For
        End If
    Next objAppt
 
    Set objAppt = Nothing
    Set objFolder = Nothing
    Set objNamespace = Nothing
    Set objOL = Nothing
    On Error GoTo 0
End Sub
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If Not olApp Is Nothing Then
        olApp.Quit
        Set olApp = Nothing
    End If
End Sub

31/07/2023, 17h53
Toro74

Merci à tous les intervenants c'est résolu par un autre biais.