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