Excel vba DatePicker MSO365 avec numéros de semaines

Invité · 12/03/2023, 13h07

Bonjour,

Envoyé par goninph

Tout fonctionne
Mais il y a un problème dans le fichier de base de patricktoulon
Lorsque l'on clique sur la croix du calendrier en haut à droite, une date bidon est lâchée dans la cellule 30/11/1999

Vous n'avez certainement pas téléchargé la bonne version v2023.4.3.2.4 ou fait trop de modifications

Envoyé par goninph

Je cherche à ajouter les numéros des jours des mois précédent et futur dans le mois en cours

Je pense que ce calendrier n'est vraiment pas fait pour vous du coup

Bonne chance

Invité · 12/03/2023, 13h26

Salut deedolith

Sinon toi, à part citer à qui veut bien l'entendre, ces 2 parole d'évangile

Envoyé par deedolith

- Viol du SRP.
- Viol de la loi de Demeter.

Tu as déjà développé quoi 🤔

A+

**goninph** · 12/03/2023, 16h26

Envoyé par BrunoM45

Bonjour,

Vous n'avez certainement pas téléchargé la bonne version v2023.4.3.2.4 ou fait trop de modifications

Je pense que ce calendrier n'est vraiment pas fait pour vous du coup

Bonne chance

Effectivement, je n'avais pas la dernière version qui a été publiée aujourd'hui, mais maintenant, c'est tout bon, tout fonctionne à merveille, merci à tous

Mon prochain objectif est d'améliorer le visuel en essayant d'afficher dans les boutons vide les numéros des jours des mois précédent ou suivant

Si vous avez des suggestions, je suis preneur, merci d'avance

**goninph** · 12/03/2023, 16h28

Envoyé par BrunoM45

Salut deedolith

Sinon toi, à part citer à qui veut bien l'entendre, ces 2 parole d'évangile

Tu as déjà développé quoi 🤔

A+

Ce n'est pas faux 😉

**deedolith** · 12/03/2023, 18h55

@BrunoM45:
Force est de constater que lorsque ces principes sont respectés, le code résultant est plus clair, plus facile à faire évoluer, plus facile à maintenir.
Quand à ce que j'ai déjà développé: Plus que je ne peut en compter, mais que je ne peut révéler pour raison de clause de confidentialité professionnelle (d'ailleurs, on ne voit pas non plus la liste de tes réalisations).
Mais je peux citer:
- Un parseur JSON (visible sur mon GitHub).

**goninph** · 12/03/2023, 21h07

Calendrier fonctionnant au double clique

- Bouton des jours fériés Vaudois Suisse coloré en rouge
- Bouton de la date récupérée coloré en orange
- Bouton de la date du jour coloré en jaune
- Boutons des jours de la fermeture de notre usine colorés en bleu (Vacances)
- Bouton pour effacer la date

Il me reste à trouver comment ajouter le numéro des jours des mois précédent et suivant sur la vue du mois sélectionnée

Merci à tous pour votre aide

Nom : 2023-03-12_19-24-10.png
Affichages : 263
Taille : 16,5 Ko

Nom : 2023-03-12_19-24-10.png
Affichages : 263
Taille : 16,5 Ko

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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
Option Explicit
'Auteur: patricktoulon/exceldownload/Version:4.1.9 maj du 26.11.2020/Adapté par Goninph 12.03.2023
'https://www.developpez.net/forums/d2147600/logiciels/microsoft-office/excel/macros-vba-excel/excel-vba-datepicker-mso365-numeros-semaines/#post11929194
'A copier dans la feuille
'''''''Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'''''''Dim DateFormats, DF 'Afficher le calendrier selon le format de la cellule
'''''''    DateFormats = Array("ddd dd mm yy") 'format à reproduire dans la cellule pour activer le calendrier par ex: jjj jj mm aaaa
'''''''    For Each DF In DateFormats
'''''''        If DF = Target.NumberFormat Then
'''''''            Cancel = True 'Empêche l'édition de la cellule active (F2) lors de Worksheet_BeforeDoubleClick Cancel = True permet de resortir du mode édition
'''''''            Target = USF_Calendrier_Sem_Ferie.ShowX(Target)
'''''''        End If
'''''''    Next
'''''''End Sub
'A copier dans un userform
'''''''Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'''''''    TextBox1 = USF_Calendrier_Sem_Ferie.ShowX(TextBox1)
'''''''End Sub
Const bt1Back As Variant = &HE0E0E0          'Couleur Background bouton jour
Const bt1fc As Variant = &H0&                'Couleur texte bouton jour
Const btweekBack As Variant = &H80000004     'Couleur Background bouton jour weekend
Const btweekfc As Variant = &H808080         'Couleur texte bouton jour weekend
Const mobildayback As Variant = &HC0FFFF     'Couleur Background bouton jour mobile
Const mobildayFC As Variant = &HFF0000       'Couleur texte jour mobile
Const bt2Back As Variant = &H80000004        'Couleur Background boutons jour vide
Const backfériéday As Variant = &HC0C0FF     'Couleur Background boutons jour férié
Const fériédayFC As Variant = &H0&           'Couleur texte bouton jour férié
Const backDayRemonter As Variant = &H80C0FF  'Couleur Background bouton jour de la cellule ou usf
Const backDayVacances As Variant = &HFFFF80  'Couleur Background bouton vacances
Public region
Public Obj As Object
Public WithEvents Bout As MSForms.CommandButton   'map pour 42 bouton
Public lance As Boolean
Public jour
Public mois
Public an
Public valeur As Date
Public objX As Object
Private clavier(43) As New USF_Calendrier_Sem_Ferie    'tableau d'instance de l'userform
Public Function ShowX(Optional objX As Object)
Dim t#
Dim Forme
    region = 13 'optionRegionale
    Set Obj = objX    'les variables argument doivent etre instruites  avant le show IMPORTANT!!!!!!!!!!
    lance = True
    'Option de placement
    Me.startupposition = 0
    Me.Left = Application.ActiveWindow.Left
    Me.Top = Application.ActiveWindow.Top - 12
    Me.Show
    If TypeName(Obj) = "Range" Then
        valeur = DateSerial(an, mois, jour)
    Else
        valeur = format(DateSerial(an, mois, jour), Forme)
    End If
    If valeur = "30/11/1999" Then
        ShowX = "" 'On modifie  valeur apres le show
    Else
        ShowX = valeur 'On modifie  valeur apres le show
    End If
    Unload Me
End Function
Private Sub UserForm_Activate()
Dim i&, TRT$
    If Not lance Then Unload Me: MsgBox " c'est une boite de dialogue plus un userform" & vbCrLf & "il se lance uniquememt par une de ses deux fonctions " & vbCrLf & """ShowX"" ou   ""ShowTopLeft""": Exit Sub
    ldate.Caption = "Aujourd'hui " & format(Date, "dddd dd.mm.yyyy")
    config
    Me.Caption = "Calendrier avec fériés vaudois"
    For i = 1 To 42: Set clavier(i).Bout = Me.Controls("j" & i): Next    'mappage pour evenement unique (42 boutons) (intra userform sans module classe)
    Me.Repaint
End Sub
Sub config()
    Dim Listdays, La_Date, i&
    USF_Calendrier_Sem_Ferie.region = 13
    USF_Calendrier_Sem_Ferie.Cbmonth.List = Split("Janvier, Février, Mars, Avril, Mai, Juin, Juillet, Août, Septembre, Octobre, Novembre, Décembre", ",")
    If Not Obj Is Nothing Then 'Remonte la date existante dans le calendrier
        If IsDate(Obj) Then
            La_Date = Obj.Value
            BT_Old_Value_JJ.Caption = Day(La_Date)
            BT_Old_Value_MM.Caption = Month(La_Date)
            BT_Old_Value_AA.Caption = Year(La_Date)
        Else
            La_Date = Date
            BT_Old_Value_JJ.Caption = 0
            BT_Old_Value_MM.Caption = 0
            BT_Old_Value_AA.Caption = 0
        End If
    End If
    USF_Calendrier_Sem_Ferie.Cbmonth.ListIndex = Month(La_Date) - 1
    For i = 2023 To Year(La_Date) + 20: USF_Calendrier_Sem_Ferie.Cbyear.AddItem i: Next
    SpinButton1.Value = Month(La_Date): SpinButton2.Value = Year(La_Date)
    ReloadClavier
    Me.Repaint
End Sub
'Evenement unique pour 42 boutons
Private Sub Bout_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    With USF_Calendrier_Sem_Ferie: .jour = Bout.Caption: .mois = .Cbmonth.ListIndex + 1: .an = .Cbyear.Value: .Hide: End With    'le unload se fait ailleurs
End Sub
Private Sub ldate_Click()
Dim Listdays, La_Date, i&
    If USF_Calendrier_Sem_Ferie.region = 1000 Then USF_Calendrier_Sem_Ferie.region = Application.International(xlDateOrder)    'AUTOMATIQUE SYSTEM
    USF_Calendrier_Sem_Ferie.Cbmonth.List = Split("Janvier, Février, Mars, Avril, Mai, Juin, Juillet, Août, Septembre, Octobre, Novembre, Décembre", ",")
    La_Date = Date
    USF_Calendrier_Sem_Ferie.Cbmonth.ListIndex = Month(La_Date) - 1
    For i = 2023 To Year(La_Date) + 20: USF_Calendrier_Sem_Ferie.Cbyear.AddItem i: Next
    SpinButton1.Value = Month(La_Date): SpinButton2.Value = Year(La_Date)
    ReloadClavier
    Me.Repaint
End Sub
'Evenement combobox et spinbutton des mois et des années
Private Sub SpinButton1_Change():
    With SpinButton1
        If .Value = 0 Then .Value = 12: Cbyear.Value = Cbyear.Value - 1
        If .Value = 13 Then .Value = 1: Cbyear.Value = Cbyear.Value + 1
        Cbmonth.ListIndex = .Value - 1:
    End With
End Sub
'Mise ajour du clavier
Public Sub ReloadClavier()
    Dim X&, i&, A&, NB_JOURS&, Y&, WkD&
    If Cbmonth.Value = "" Or Cbyear.Value = "" Then Exit Sub
    Select Case USF_Calendrier_Sem_Ferie.region
    Case 0, 22: WkD = vbSunday
    Case 1, 2, 12, 13: WkD = vbMonday
    End Select
    X = Weekday(DateSerial(USF_Calendrier_Sem_Ferie.Cbyear, USF_Calendrier_Sem_Ferie.Cbmonth.ListIndex + 1, 1), WkD)
    NB_JOURS = Day(DateSerial(Cbyear.Value, Cbmonth.ListIndex + 2, 0))
    For i = 1 To 6: Me.Controls("sem" & i).Caption = "": Next
    For i = 1 To 42
        With USF_Calendrier_Sem_Ferie.Controls("j" & i)
            .Caption = "": .Enabled = False: .BackColor = bt2Back: .ControlTipText = ""
            If i >= X And A <= NB_JOURS - 1 Then
                .Visible = True: A = A + 1: .Enabled = True: .Caption = A ' .BackColor = bt1Back
                Y = CLng(DateSerial(USF_Calendrier_Sem_Ferie.Cbyear.Value, USF_Calendrier_Sem_Ferie.Cbmonth.ListIndex + 1, A))
                Controls(.Tag).Caption = Evaluate("= TRUNC((" & Y & "-WEEKDAY(" & Y & ",2)+11-DATE(YEAR(" & Y & "-WEEKDAY(" & Y & " ,2)+4),1,1))/7)")
                .BackColor = férié(i)
            End If
        End With
    Next
End Sub
Private Function férié(i)
Dim La_Date As Date, paques As Date, ctrlJ As Object, CF^
Dim Date_Remontee As Variant
Dim Date_Début_Vacances As Variant
    Set ctrlJ = USF_Calendrier_Sem_Ferie.Controls("J" & i)
    La_Date = DateSerial(Cbyear, Cbmonth.ListIndex + 1, ctrlJ.Caption)
    paques = CDate(((Round(DateSerial(Cbyear.Value, 4, (234 - 11 * (Cbyear.Value Mod 19)) Mod 30) / 7, 0) * 7) - 6))
    férié = bt1Back: CF = bt1fc    'couleur base
    ctrlJ.ForeColor = bt1fc
    Date_Remontee = BT_Old_Value_JJ.Caption & "." & BT_Old_Value_MM.Caption & "." & BT_Old_Value_AA.Caption
    If Date_Remontee <> "0.0.0" Then
        Date_Remontee = BT_Old_Value_JJ.Caption & "." & BT_Old_Value_MM.Caption & "." & BT_Old_Value_AA.Caption
    Else
        Date_Remontee = 0
    End If
    Date_Début_Vacances = CDate("21/07/23") 'Début des vacances d'été
    Select Case region
        Case 13    'suisse
        If Weekday(DateSerial(USF_Calendrier_Sem_Ferie.Cbyear, USF_Calendrier_Sem_Ferie.Cbmonth.ListIndex + 1, ctrlJ.Caption), vbMonday) > 5 Then férié = btweekBack: CF = btweekfc
            Select Case True
'            Case La_Date = CDate("01/03/" & Cbyear): férié = backfériéday: ctrlJ.ControlTipText = "Mardi Gras": CF = fériédayFC
            Case La_Date = CDate("01/01/" & Cbyear): férié = backfériéday: ctrlJ.ControlTipText = "Jour de l'an": CF = fériédayFC
            Case La_Date = CDate("02/01/" & Cbyear): férié = backfériéday: ctrlJ.ControlTipText = "Vaud et Jura": CF = fériédayFC
            Case La_Date = paques - 2: férié = backfériéday: ctrlJ.ControlTipText = "Vendredi saint": CF = fériédayFC
            Case La_Date = paques: férié = backfériéday: ctrlJ.ControlTipText = "Pâques": CF = fériédayFC
            Case La_Date = paques + 1: férié = backfériéday: ctrlJ.ControlTipText = "Lundi de Pâques": CF = fériédayFC
            Case La_Date = CDate("01/05/" & Cbyear.Value): férié = backfériéday: ctrlJ.ControlTipText = "Fête du travail": CF = fériédayFC
            Case La_Date = paques + 39: férié = backfériéday: ctrlJ.ControlTipText = "Ascension": CF = fériédayFC
            Case La_Date = paques + 40: férié = backDayVacances: ctrlJ.ControlTipText = "Pont de l'ascension": CF = fériédayFC
            Case La_Date = paques + 49: férié = backfériéday: ctrlJ.ControlTipText = "Pentecôte": CF = fériédayFC
            Case La_Date = paques + 50: férié = backfériéday: ctrlJ.ControlTipText = "Lundi de Pentecôte": CF = fériédayFC
            Case La_Date = CDate("01/08/" & Cbyear.Value): férié = backfériéday: ctrlJ.ControlTipText = "Fête Nationale": CF = fériédayFC
            Case La_Date = CDate("22/09/" & Cbyear) - Weekday("22/09/" & Cbyear.Value, 2): férié = backfériéday: ctrlJ.ControlTipText = "Jeûne Fédéral": CF = fériédayFC
            Case La_Date = CDate("22/09/" & Cbyear) - Weekday("22/09/" & Cbyear.Value, 2) + 1: férié = backfériéday: ctrlJ.ControlTipText = "Lundi du Jeûne": CF = fériédayFC
            Case La_Date = CDate("25/12/" & Cbyear): férié = backfériéday: ctrlJ.ControlTipText = "Noel": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 1): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 2): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 3): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 4): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 5): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 6): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 7): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 8): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 9): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 10): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 11): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 12): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 13): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 14): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 15): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 16): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 17): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 18): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 19): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 20): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 21): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 22): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = CDate(Date_Début_Vacances + 23): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances": CF = fériédayFC
            Case La_Date = Date: férié = mobildayback: CF = mobildayFC: ctrlJ.ControlTipText = "Aujourd'hui"
            Case La_Date = CDate(Date_Remontee): férié = backDayRemonter: ctrlJ.ControlTipText = "Date saisie": CF = fériédayFC
        End Select
    End Select
    ctrlJ.ForeColor = CF
End Function
Private Sub Cbmonth_Change(): SpinButton1.Value = Cbmonth.ListIndex + 1: USF_Calendrier_Sem_Ferie.ReloadClavier: End Sub
Private Sub Cbmonth_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger): KeyAscii = 0: End Sub
Private Sub Cbyear_Change(): SpinButton2.Value = Cbyear.Value: USF_Calendrier_Sem_Ferie.ReloadClavier: End Sub
Private Sub Cbyear_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger): KeyAscii = 0: End Sub
Private Sub SpinButton2_Change(): Cbyear.Value = SpinButton2.Value: End Sub
Private Sub BT_Fermer_Click() 'Ferme avec l'ancienne valeur
   With USF_Calendrier_Sem_Ferie: .jour = BT_Old_Value_JJ.Caption: .mois = BT_Old_Value_MM.Caption: .an = BT_Old_Value_AA.Caption: .Hide: End With   'le unload se fait ailleurs
End Sub
Private Sub BT_Effacer_Click() 'Efface et ferme avec la valeur à rien
   With USF_Calendrier_Sem_Ferie: .jour = 0: .mois = 0: .an = 0: .Hide: End With    'le unload se fait ailleurs
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = 0 Then
        With USF_Calendrier_Sem_Ferie: .jour = BT_Old_Value_JJ.Caption: .mois = BT_Old_Value_MM.Caption: .an = BT_Old_Value_AA.Caption: End With
        Cancel = True
        Me.Hide
    Else
        Cancel = False
    End If
End Sub

**deedolith** · 13/03/2023, 00h26

Attention,
les vacances ne sont pas des jours fériés.

Une piste pour remplir les numeros des jours: (extrait de code sur un calendrier que je développe de mon côté),
en supposant que les Labels se nomment de "day1" à "day42":

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
Private Sub SetLabels(ByVal dt As Date)
    Dim DayToAdd As Integer
    DayToAdd = 0
 
    Dim LabelNumber As Integer
    For LabelNumber = Day(dt) + Weekday(dt) To 1 Step -1
        Controls("day" & LabelNumber).Caption = Day(DateAdd("d", DayToAdd, dt))
        Controls("day" & LabelNumber).Tag = Format(DateAdd("d", DayToAdd, dt), "dd/mm/yyyy")
        DayToAdd = DayToAdd - 1
    Next
 
    DayToAdd = 0
    For LabelNumber = Day(dt) + Weekday(dt) To 42
        Controls("day" & LabelNumber).Caption = Day(DateAdd("d", DayToAdd, dt))
        Controls("day" & LabelNumber).Tag = Format(DateAdd("d", DayToAdd, dt), "dd/mm/yyyy")
        DayToAdd = DayToAdd + 1
    Next
End Sub

**goninph** · 13/03/2023, 12h21

Mon prochain objectif est un calendrier de 84 jours

Première ligne du calendrier = semaine de la date remontée ou d'aujourd'hui si pas de date remontée

Ajouter une colonne pour les mois en face de chaque ligne comme pour les semaines

Pour m'en sortir je pense inscrire la date complète dans le champ ControlTipText de chaque bouton (via une boucle)

Seul le premier bouton dépendra des combobox Mois et Année les autres jours seront incrémenter de +1 jour sur la date complète du bouton précédent

Une couleur pour les mois paire et une autre pour les mois impaires

Y'a du boulot

Nom : 2023-03-13_13-30-43.png
Affichages : 236
Taille : 39,6 Ko

Nom : 2023-03-13_13-30-43.png
Affichages : 236
Taille : 39,6 Ko

**deedolith** · 13/03/2023, 14h31

Heu la, on dévie sur une mécanique totalement différente d'un calendrier standard.
Seul l'affichage à un semblant de commun.

Renseignes-toi sur les classes, l'héritage, les évènements (le Design Pattern Observer peut être utile également), les mécaniques à mettre en œuvre pour que plusieurs contrôles répondent par le même gestionnaire d'évènement, voir la création dynamique de controls.

**goninph** · 14/03/2023, 23h10

Yes je suis à bout touchant

Je deviens fou tout fonctionne sauf la couleur des boutons, il y a un décalge de 1 jour, par contre les textes des fériés s'inscrivent dans les ControlTipText du bon bouton

Le fichier est en pièce jointe

Merci d'avance pour vos lumières
Nom : 2023-03-14_22-45-38.png
Affichages : 222
Taille : 99,2 Ko

Nom : 2023-03-14_22-45-38.png
Affichages : 222
Taille : 99,2 Ko

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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
Option Explicit
'Auteur: patricktoulon/exceldownload/Version:4.1.9 maj du 26.11.2020/Adapté par Goninph 14.03.2023
'https://www.developpez.net/forums/d2147600/logiciels/microsoft-office/excel/macros-vba-excel/excel-vba-datepicker-mso365-numeros-semaines/#post11929194
Const bt1Back As Variant = &HE0E0E0          'Couleur Background bouton jour
Const bt1fc As Variant = &H0&                'Couleur texte bouton jour
Const btweekBack As Variant = &H80000004     'Couleur Background bouton jour weekend
Const btweekfc As Variant = &H808080         'Couleur texte bouton jour weekend
Const mobildayback As Variant = &HC0FFFF     'Couleur Background bouton jour mobile
Const mobildayFC As Variant = &HFF0000       'Couleur texte jour mobile
Const bt2Back As Variant = &H80000004        'Couleur Background boutons jour vide
Const backfériéday As Variant = &HC0C0FF     'Couleur Background boutons jour férié
Const fériédayFC As Variant = &H0&           'Couleur texte bouton jour férié
Const backDayRemonter As Variant = &H80C0FF  'Couleur Background bouton jour de la cellule ou usf
Const backDayVacances As Variant = &HFFFF80  'Couleur Background bouton vacances
Public region
Public Obj As Object
Public WithEvents Bout As MSForms.CommandButton   'map pour 42 bouton
Public lance As Boolean
Public jour
Public mois
Public an
Public valeur As Date
Public objX As Object
Private clavier(118) As New USF_Calendrier_3_Mois    'tableau d'instance de l'userform
Public Function ShowX(Optional objX As Object)
Dim t#
Dim Forme
    Set Obj = objX    'les variables argument doivent etre instruites  avant le show IMPORTANT!!!!!!!!!!
    lance = True
    'Option de placement
    Me.startupposition = 0
    Me.Left = Application.ActiveWindow.Left
    Me.Top = Application.ActiveWindow.Top
    Me.Show
    If TypeName(Obj) = "Range" Then
        valeur = DateSerial(an, mois, jour)
    Else
        valeur = format(DateSerial(an, mois, jour), Forme)
    End If
    If valeur = "30/11/1999" Then
        ShowX = "" 'On modifie  valeur apres le show
    Else
        ShowX = valeur 'On modifie  valeur apres le show
    End If
    Unload Me
End Function
Private Sub UserForm_Activate()
Dim i&, TRT$
    If Not lance Then Unload Me: MsgBox " c'est une boite de dialogue plus un userform" & vbCrLf & "il se lance uniquememt par une de ses deux fonctions " & vbCrLf & """ShowX"" ou   ""ShowTopLeft""": Exit Sub
    ldate.Caption = "Aujourd'hui " & format(Date, "dddd dd.mm.yyyy")
    config
    Me.Caption = "Calendrier avec fériés vaudois"
    For i = 1 To 118: Set clavier(i).Bout = Me.Controls("j" & i): Next    'mappage pour evenement unique (42 boutons) (intra userform sans module classe)
    Me.Repaint
End Sub
Sub config()
    Dim Listdays, La_Date, i&
    USF_Calendrier_3_Mois.region = 13
    USF_Calendrier_3_Mois.Cbmonth.List = Split("Janvier, Février, Mars, Avril, Mai, Juin, Juillet, Août, Septembre, Octobre, Novembre, Décembre", ",")
    If Not Obj Is Nothing Then
        If IsDate(Obj) Then
            La_Date = Obj.Value 'Remonte la date existante dans le calendrier
            BT_Old_Value_JJ.Caption = Day(La_Date)
            BT_Old_Value_MM.Caption = Month(La_Date)
            BT_Old_Value_AA.Caption = Year(La_Date)
        Else
            La_Date = Date      'Si pas de date = Aujourd'hui
            BT_Old_Value_JJ.Caption = 0
            BT_Old_Value_MM.Caption = 0
            BT_Old_Value_AA.Caption = 0
        End If
    End If
    USF_Calendrier_3_Mois.Cbmonth.ListIndex = Month(La_Date) - 1
    For i = 2023 To Year(La_Date) + 20: USF_Calendrier_3_Mois.Cbyear.AddItem i: Next
    SpinButton1.Value = Month(La_Date): SpinButton2.Value = Year(La_Date)
    ReloadClavier
    Me.Repaint
End Sub
Private Sub ldate_Click()
Dim Listdays, La_Date, i&
    USF_Calendrier_3_Mois.Cbmonth.List = Split("Janvier, Février, Mars, Avril, Mai, Juin, Juillet, Août, Septembre, Octobre, Novembre, Décembre", ",")
    La_Date = Date
    USF_Calendrier_3_Mois.Cbmonth.ListIndex = Month(La_Date) - 1
    For i = 2023 To Year(La_Date) + 20: USF_Calendrier_3_Mois.Cbyear.AddItem i: Next
    SpinButton1.Value = Month(La_Date): SpinButton2.Value = Year(La_Date)
    ReloadClavier
    Me.Repaint
End Sub
Private Sub SpinButton1_Change(): 'Evenement combobox et spinbutton des mois et des années
    With SpinButton1
        If .Value = 0 Then .Value = 12: Cbyear.Value = Cbyear.Value - 1
        If .Value = 13 Then .Value = 1: Cbyear.Value = Cbyear.Value + 1
        Cbmonth.ListIndex = .Value - 1:
    End With
End Sub
Private Sub Cbmonth_Change(): SpinButton1.Value = Cbmonth.ListIndex + 1: USF_Calendrier_3_Mois.ReloadClavier: End Sub
Private Sub Cbmonth_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger): KeyAscii = 0: End Sub
Private Sub Cbyear_Change(): SpinButton2.Value = Cbyear.Value: USF_Calendrier_3_Mois.ReloadClavier: End Sub
Private Sub Cbyear_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger): KeyAscii = 0: End Sub
Private Sub SpinButton2_Change(): Cbyear.Value = SpinButton2.Value: End Sub
'Mise ajour du clavier
Public Sub ReloadClavier()
Dim i As Long
Dim La_Date_clavier As Date
Dim Jour_de_la_date As Variant
    If Cbmonth.Value = "" Or Cbyear.Value = "" Then Exit Sub
    'La date de départ pour le mappage du clavier
    If IsDate(Obj) Then
        La_Date_clavier = Obj.Value 'Remonte la date existante dans le calendrier
    Else
        La_Date_clavier = Date 'Si pas de date = Aujourd'hui
    End If
    Jour_de_la_date = format(La_Date_clavier, "dd")
    La_Date_clavier = Lundi_de_La_date(DateSerial(USF_Calendrier_3_Mois.Cbyear, USF_Calendrier_3_Mois.Cbmonth.ListIndex + 1, Jour_de_la_date), vbMonday)
    'Mappage des mois
    USF_Calendrier_3_Mois.Controls("Mois1").Caption = format(CDate(La_Date_clavier), "mmm")
    USF_Calendrier_3_Mois.Controls("Mois1").ControlTipText = CDate(La_Date_clavier)
    For i = 1 To 16
        With USF_Calendrier_3_Mois.Controls("Mois" & i + 1)
        .Caption = format(CDate(USF_Calendrier_3_Mois.Controls("Mois" & (i)).ControlTipText) + 7, "mmm")
        .ControlTipText = CDate(USF_Calendrier_3_Mois.Controls("Mois" & (i)).ControlTipText) + 7
        End With
    Next
    'Mappage des semaines
    USF_Calendrier_3_Mois.Controls("sem1").Caption = WeekNoIso(CDate(La_Date_clavier))
    USF_Calendrier_3_Mois.Controls("sem1").ControlTipText = CDate(La_Date_clavier)
    For i = 1 To 16
        With USF_Calendrier_3_Mois.Controls("sem" & i + 1)
        .Caption = WeekNoIso(CDate(USF_Calendrier_3_Mois.Controls("Sem" & (i)).ControlTipText) + 7)
        .ControlTipText = CDate(USF_Calendrier_3_Mois.Controls("sem" & (i)).ControlTipText) + 7
        End With
    Next
    'Mappage des jours
    USF_Calendrier_3_Mois.Controls("j1").Caption = format(CDate(La_Date_clavier), "d")
    USF_Calendrier_3_Mois.Controls("j1").ControlTipText = CDate(La_Date_clavier)
    For i = 1 To 118
        With USF_Calendrier_3_Mois.Controls("j" & i + 1)
            Jour_de_la_date = format(CDate(USF_Calendrier_3_Mois.Controls("j" & (i)).ControlTipText) + 1, "d")
            .Caption = Jour_de_la_date
            .ControlTipText = CDate(USF_Calendrier_3_Mois.Controls("j" & (i)).ControlTipText) + 1
            .BackColor = férié(i)
        End With
    Next
End Sub
Private Sub Bout_DblClick(ByVal Cancel As MSForms.ReturnBoolean) 'Evenement unique pour 42 boutons
Dim La_Date As Variant
    With USF_Calendrier_3_Mois
        .jour = format(Right(Bout.ControlTipText, 10), "dd")
        .mois = format(Right(Bout.ControlTipText, 10), "mm")
        .an = format(Right(Bout.ControlTipText, 10), "yyyy")
        .Hide
    End With    'le unload se fait ailleurs
End Sub
Private Function férié(i)
Dim La_Date As Date, paques As Date, ctrlJ As Object, CF
Dim Date_Remontee As Variant
Dim Date_Début_Vacances As Variant
 
    Set ctrlJ = USF_Calendrier_3_Mois.Controls("J" & i)
 
 
    La_Date = CDate(USF_Calendrier_3_Mois.Controls("J" & i).ControlTipText)
 
    paques = CDate(((Round(DateSerial(Cbyear.Value, 4, (234 - 11 * (Cbyear.Value Mod 19)) Mod 30) / 7, 0) * 7) - 6))
 
    férié = bt1Back
 
    CF = bt1fc   'couleur base
    ctrlJ.ForeColor = bt1fc
    'Coloré la date remontée
    Date_Remontee = BT_Old_Value_JJ.Caption & "." & BT_Old_Value_MM.Caption & "." & BT_Old_Value_AA.Caption
    If Date_Remontee <> "0.0.0" Then
        Date_Remontee = BT_Old_Value_JJ.Caption & "." & BT_Old_Value_MM.Caption & "." & BT_Old_Value_AA.Caption
    Else
        Date_Remontee = 0
    End If
    Date_Début_Vacances = CDate("21/07/23") 'Début des vacances d'été
    Select Case True
        Case La_Date = CDate("01/01/" & Cbyear): férié = backfériéday: ctrlJ.ControlTipText = "Jour de l'an - " & La_Date: CF = fériédayFC
        Case La_Date = CDate("02/01/" & Cbyear): férié = backfériéday: ctrlJ.ControlTipText = "Vaud et Jura - " & La_Date: CF = fériédayFC
        Case La_Date = paques - 2: férié = backfériéday: ctrlJ.ControlTipText = "Vendredi saint - " & La_Date: CF = fériédayFC
        Case La_Date = paques: férié = backfériéday: ctrlJ.ControlTipText = "Pâques - " & La_Date: CF = fériédayFC
        Case La_Date = paques + 1: férié = backfériéday: ctrlJ.ControlTipText = "Lundi de Pâques - " & La_Date: CF = fériédayFC
        Case La_Date = CDate("01/05/" & Cbyear.Value): férié = backfériéday: ctrlJ.ControlTipText = "Fête du travail - " & La_Date: CF = fériédayFC
        Case La_Date = paques + 39: férié = backfériéday: ctrlJ.ControlTipText = "Ascension - " & La_Date: CF = fériédayFC
        Case La_Date = paques + 40: férié = backDayVacances: ctrlJ.ControlTipText = "Pont de l'ascension - " & La_Date: CF = fériédayFC
        Case La_Date = paques + 49: férié = backfériéday: ctrlJ.ControlTipText = "Pentecôte - " & La_Date: CF = fériédayFC
        Case La_Date = paques + 50: férié = backfériéday: ctrlJ.ControlTipText = "Lundi de Pentecôte - " & La_Date: CF = fériédayFC
        Case La_Date = CDate("01/08/" & Cbyear.Value): férié = backfériéday: ctrlJ.ControlTipText = "Fête Nationale - " & La_Date: CF = fériédayFC
        Case La_Date = CDate("22/09/" & Cbyear) - Weekday("22/09/" & Cbyear.Value, 2): férié = backfériéday: ctrlJ.ControlTipText = "Jeûne Fédéral - " & La_Date: CF = fériédayFC
        Case La_Date = CDate("22/09/" & Cbyear) - Weekday("22/09/" & Cbyear.Value, 2) + 1: férié = backfériéday: ctrlJ.ControlTipText = "Lundi du Jeûne - " & La_Date: CF = fériédayFC
        Case La_Date = CDate("25/12/" & Cbyear): férié = backfériéday: ctrlJ.ControlTipText = "Noel - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 1): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 2): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 3): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 4): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 5): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 6): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 7): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 8): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 9): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 10): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 11): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 12): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 13): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 14): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 15): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 16): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 17): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 18): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 19): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 20): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 21): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 22): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = CDate(Date_Début_Vacances + 23): férié = backDayVacances: ctrlJ.ControlTipText = "Vacances - " & La_Date: CF = fériédayFC
        Case La_Date = Date: férié = mobildayback: CF = mobildayFC: ctrlJ.ControlTipText = "Aujourd'hui - " & La_Date
        Case La_Date = CDate(Date_Remontee): férié = backDayRemonter: ctrlJ.ControlTipText = "Date saisie - " & La_Date: CF = fériédayFC
    End Select
'ctrlJ.ForeColor = CF
End Function
Private Sub BT_Fermer_Click() 'Ferme avec l'ancienne valeur
   With USF_Calendrier_3_Mois: .jour = BT_Old_Value_JJ.Caption: .mois = BT_Old_Value_MM.Caption: .an = BT_Old_Value_AA.Caption: .Hide: End With   'le unload se fait ailleurs
End Sub
Private Sub BT_Effacer_Click() 'Efface et ferme avec la valeur à rien
   With USF_Calendrier_3_Mois: .jour = 0: .mois = 0: .an = 0: .Hide: End With    'le unload se fait ailleurs
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = 0 Then
        With USF_Calendrier_3_Mois: .jour = BT_Old_Value_JJ.Caption: .mois = BT_Old_Value_MM.Caption: .an = BT_Old_Value_AA.Caption: End With
        Cancel = True
        Me.Hide
    Else
        Cancel = False
    End If
End Sub
'N° semaine EURO VBA
Function WeekNoIso(MyDate As Date) As Integer
  WeekNoIso = Evaluate("isoweeknum(" & CLng(MyDate) & ")")
End Function
Public Function Lundi_de_La_date(ByVal dt As Date, ByVal DesiredWeekDay As VbDayOfWeek) As Date
Dim d As Date
Dim w As Integer
    d = vbMonday
    w = Weekday(dt, DesiredWeekDay)
    d = DateAdd("d", 8 - w, dt)
    Lundi_de_La_date = d
    If Lundi_de_La_date <> d Then
        Lundi_de_La_date = d - 7 'si la date initiale correspond à la date recherchée
    Else
        Lundi_de_La_date = d - 14 '-7 jours pour la semaine en cours
    End If
End Function

**deedolith** · 15/03/2023, 01h56

Peut être à cause de ca:

Code :

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

Jour_de_la_date = format(CDate(USF_Calendrier_3_Mois.Controls("j" & (i)).ControlTipText) + 1, "d")

Pourquoi le +1 ????

De plus, ta pièce jointe n'est pas la bonne (j'ai cherché "USF_Calendrier_3_Mois" sans jamais le trouver).

De plus, en utilisant des points d'arrêt, des espions, en exécutant en pas à pas (techniques de débogage de base),
tu devrais être en mesure de détecter ce genre de désagrément mineur.

Et pour être franc:
Acquiers les connaissances nécessaires avant de t'attaquer à un projet dont tu ne comprends pas la moitié (même si c'est pour l'agrémenter à ta sauce).
Avec tes modifications, ça part dans tous les sens, dorénavant, toi seul le comprend (du moins, c'est ce que j'espère).

**goninph** · 15/03/2023, 07h56

Envoyé par deedolith

Peut être à cause de ca:

Code :

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

Jour_de_la_date = format(CDate(USF_Calendrier_3_Mois.Controls("j" & (i)).ControlTipText) + 1, "d")

Pourquoi le +1 ????

De plus, ta pièce jointe n'est pas la bonne (j'ai cherché "USF_Calendrier_3_Mois" sans jamais le trouver).

De plus, en utilisant des points d'arrêt, des espions, en exécutant en pas à pas (techniques de débogage de base),
tu devrais être en mesure de détecter ce genre de désagrément mineur.

Et pour être franc:
Acquiers les connaissances nécessaires avant de t'attaquer à un projet dont tu ne comprends pas la moitié (même si c'est pour l'agrémenter à ta sauce).
Avec tes modifications, ça part dans tous les sens, dorénavant, toi seul le comprend (du moins, c'est ce que j'espère).

Merci, effectivement, le problème vient de là, mais à présent mon premier jour du mappage n'est plus le bon, il est à dimanche au lieu de lundi, je vais corriger ce soir
La pièce jointe est la bonne
Nom : 2023-03-15_07-28-01.png
Affichages : 219
Taille : 33,9 Ko

Nom : 2023-03-15_07-28-01.png
Affichages : 219
Taille : 33,9 Ko

**deedolith** · 15/03/2023, 11h54

Ben non:

Nom : Capture.PNG
Affichages : 309
Taille : 13,5 Ko

**deedolith** · 15/03/2023, 16h21

Bon ...

Faire un calendrier, ce n'est pas si sorcier que ça.
Encore faut il mener une étude (aussi minime soit-elle) et mettre en place une architecture viable avant de foncer tête baissée dans le code.

Je présente ici une solution, il y en a d'autres possible.

VBA st un langage objet, autant en tirer avantage.
De quoi avons-nous besoin ?
Au minimum, un calendrier (Calendar) et un formulaire (CalendarGUI). Ce qui nous donne au moins 2 classes (les formulaires sont des classes).
Le formulaire doit avoir suffisamment de cases (msForms.Label) pour représenter tous les jours du mois. A l'instar du calendrier Windows, il nous en faudra 42 (6 x 7).
Histoire de factoriser et de savoir où l'utilisateur click, les cases devront avoir un gestionnaire d'évènement commun. Pour cela, on passe par une 3e classe (LabelListener) , en charge d'écouter les évènements d'une case.
Par les mécaniques des évènements, une case pourra prévenir le formulaire qu'elle a été cliquée, le formulaire pourra prévenir la classe calendrier qu'une date a été choisie, et la classe calendrier pourra mettre à jour sa date interne qui sera renvoyée a l'utilisateur.

*CHOIX TECHNIQUE*
*****************
CalendarGUI devra stocker des instances de LabelListener dans un conteneur, les tableaux étant assez pénible, une collection fera l'affaire.
Mais comme une collection n'est pas capable de transmettre des evenements, (un LabelListner ne peut remonter d'evenement a CalendarGUI puisqu'il y a une collection entre les 2) il nous faut trouver une mécanique alternative.
C'est là qu'intervient le Design Pattern Observer. Il permet à une classe A d'écouter une classe B sans qu'il y aie de relation directe entre ces dernières, et c'est exactement ce qu'on recherche.
Ce pattern implique 2 interfaces (IObserver et ISubject), ainsi que des références croisées, on veillera à détruire les instances crées manuellement lors de la destruction de CalendarGUI (le ramasse miette de VBA étant limité de ce coté la).
*****************

Ensuite, il faudra stocker des données.
La date de départ, la date choisie par l'utilisateur. Ces 2 données ne feront qu'une puisque ce sera la date courante de CalendarGUI.
Les cases seront numérotées, comme on a pas envie de recalculer en permanence la date que représente une case en fonction de son numéro, on enregistre dans la propriété Tag de chaque case, la date qu'elle représente. Ca nous permet de toutes les parcourir sans se soucier de leur numéro ni de leur nom, et encore moins de faire des calculs alambiqués pour les retrouver. Une simple comparaison de la propriété Tag et la valeur recherchée suffira.

Enfin, fonctionnalités additionnelles:
- On désire positionner CalendarGUI en fonction des coordonnées d'une cellule Excel, ou d'un contrôle de formulaire quelconque.
Ce n'est pas au calendrier de se positionner, d'une part cela ajoute des dépendances, ça viole la Loi de Demeter (CalendarGUI à connaissance de données qui ne le concerne pas), ça réduit la flexibilité, et c'est source de mauvaises surprises (exemple: si une cellule est en bas / droite de l'écran, le CalendarGUI sera dessiné hors écran, rendant son utilisation impossible). C'est donc au code utilisateur de fournir les coordonnées.
- On désire prendre en considération les congés, vacances scolaires ou jours fériés, ce n'est pas non plus a CalendarGUI de prendre cela en charge, ça viole la Loi de Demeter et réduit la flexibilité (Par exemple: un pays dont les jours fériés ne sont pas basés sur la religion catholique). C'est donc au code utilisateur de fournir les listes des congés, vacances scolaires ou jours fériés.
*CHOIX TECHNIQUE*
*****************
Afin de minimiser les erreurs de programmation, on fournira des collections de dates, itérable et fortement typée représentant ces listes, ce qui implique une nouvelle classe: Dates.

On fait de la POO, VBA ne fournissant pas de constructeur paramétré, on en fournira un.
On mettra également en place des fonctions "Factory" en charge d'instancier les classes (cela évite entre autre de mettre en place des propriétés en écriture, qui n'ont pas de sens).
*****************

Résumé de l'architecture:
1 formulaire: CalendarGUI
3 classes: Calendar, LabelListener, Dates
2 interfaces: IObserver, ISubject.
Calendar est le point d'entrée / sortie avec le code utilisateur, elle instancie CalendarGUI, transmet les paramètres à CalendarGUI.
CalendarGUI, hérite de IObserver, instancie une collection de LabelListener
LabelListener, hérité de ISubject, doit s'abonner auprès de CalendarGUI.
Dates, 3 instances représentant la liste des jours de vacances, congés, fériés.

Voila pour l'étude / architecture.
Le code arriveras prochainement.

**goninph** · 15/03/2023, 17h19

Envoyé par deedolith

Ben non:

Effectivement, nouvel essai

**deedolith** · 15/03/2023, 19h36

Heu ... repart de zéro.

Le mix du code originel (lourdingue, qui réinvente la roue), tes modifications saignantes faites à l'arrache, ca donne ce qu'on appelle un code spaghetti, le truc impossible à démêler, et qu'il faut combattre.

Je n'arrête pas de le rabâcher, et ce n'est pas innocent, en développement logiciels, le SRP: https://en.wikipedia.org/wiki/Single...lity_principle et la Loi de Demeter https://en.wikipedia.org/wiki/Law_of_Demeter , voir les principes SOLID https://en.wikipedia.org/wiki/SOLID (quel bel acronyme n'est-ce pas ?) sont tes meilleurs amis.

Donc mon meilleur conseil:
Repart de zéro.

Pour information, ci joint le calendrier que j'ai développé ces dernières 24h.
J'espère que ca t'inspireras d'avantage que ce que tu as commis jusqu'à présent.
Calendar.xlsm

**goninph** · 19/03/2023, 22h13

Bonjour,

Je vais tester demain. Bonne soirée

Nom : 2023-03-19_17-59-48.png
Affichages : 202
Taille : 37,2 Ko

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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
Option Explicit
'A placer dans la feuille
'Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'Dim DateFormats, DF 'Afficher le calendrier selon le format de la cellule
'    DateFormats = Array("ddd dd/mm/yy") 'Format dans la cellule jjj jj.mm.aa
'    For Each DF In DateFormats
'        If DF = Target.NumberFormat Then
'            Target = USF_Calendar.ShowX(Target)
'            Cancel = True 'Worksheet_BeforeDoubleClick Cancel = True permet de resortir du mode édition F2)
'        End If
'    Next
'End Sub
'A copier dans un userform
'''''''Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'''''''    TextBox1 = USF_Calendar.ShowX(TextBox1)
'''''''End Sub
'Sur la base du calendrier de patricktoulon/exceldownload/Version:4.1.9 maj du 26.11.2020/Adapté par Goninph 19.03.2023
'https://www.developpez.net/forums/d2147600/logiciels/microsoft-office/excel/macros-vba-excel/excel-vba-datepicker-mso365-numeros-semaines/#post11929194
Const Couleur_BT_Defaut As Variant = &HE0E0E0
Const Couleur_BT_Aujourdhui As Variant = &HC0FFFF
Const Couleur_BT_Ferie As Variant = &HC0C0FF
Const Couleur_BT_Date_Remontee As Variant = &H80C0FF
Const Couleur_BT_Vacances As Variant = &HFFFF80
Const Couleur_BT_Mois_Paire As Variant = &HFFFFFF
Const Couleur_Police_Defaut As Variant = &H0&
Const Couleur_Police_Mois_Actuel As Variant = &HFF0000
Const Couleur_Police_Weekend As Variant = &HC0C0C0
Public Obj As Object
Public WithEvents Bout As MSForms.CommandButton   'map pour 42 bouton
Public lance As Boolean
Public La_date As Variant
Public valeur As Variant
Public objX As Object
Public Ancienne_Valeur As Variant
Public Nouvelle_Date As Variant
Private clavier(119) As New USF_Calendar    'tableau d'instance de l'userform
Public Function ShowX(Optional objX As Object)
Dim Forme As Variant
    Set Obj = objX 'les variables argument doivent etre instruites avant le show IMPORTANT!!!!!!!!!!
    lance = True
    'Option de placement
    Me.startupposition = 0
    Me.Left = Windows.Application.Left + Windows.Application.Width / 2 - Me.Width / 2
    Me.Top = Windows.Application.Top + Windows.Application.Height / 2 - Me.Height / 2
    'Ouvre le calendrier
    Me.Show
    'Redonne la date lors du clique sur un jour du calendrier
    If IsDate(Nouvelle_Date) Then
        If TypeName(Obj) = "Range" Then 'Vérifier si cette une cellule ou un contrôle
            valeur = Nouvelle_Date
            ShowX = valeur 'Donne la date dans une cellule
        Else
            valeur = format(Nouvelle_Date, Forme)
            ShowX = valeur 'Donne la date dans un contrôle
        End If
    Else
        ShowX = valeur 'Redonne la valeur si c'est du texte ou vide
    End If
    Unload Me
End Function
Private Sub Bout_DblClick(ByVal Cancel As MSForms.ReturnBoolean) 'Evenement unique pour 42 boutons
    With USF_Calendar
        .Nouvelle_Date = CDate(Bout.Tag)
        .Hide 'unload dans la fonction ShowX
    End With
End Sub
Private Sub UserForm_Activate()
Dim i As Long
    If Not lance Then Unload Me: MsgBox " c'est une boite de dialogue plus un userform" & vbCrLf & "il se lance uniquememt par une de ses deux fonctions " & vbCrLf & """ShowX"" ou   ""ShowTopLeft""": Exit Sub
    BT_Aujourdhui.Caption = "Aujourd'hui " & format(Date, "dddd dd.mm.yyyy")
    config
    Me.Caption = "Calendrier Suisse et fériés vaudois"
    For i = 1 To 119: Set clavier(i).Bout = Me.Controls("j" & i): Next    'mappage pour evenement unique (42 boutons) (intra userform sans module classe)
    Me.Repaint
End Sub
Sub config()
Dim Listdays As Variant
Dim i As Long
    Me.Combobox_Mois.List = Split("janvier,février,mars,avril,mai,juin,juillet,août,septembre,octobre,novembre,décembre", ",")
    Ancienne_Valeur = Obj.Value
    'Remonte la date existante dans le calendrier
    If Not Obj Is Nothing Then
        If IsDate(Obj) Then
            If Obj.Value < CDate("01.01.1901") Then
                La_date = CDate("01.01.1901")
            Else
                La_date = Obj.Value 'si il y a une date existante
            End If
        Else
            La_date = Date      'si il n'y pas de date existante
        End If
    End If
    Me.Combobox_Mois.ListIndex = Month(La_date) - 1
    For i = 2023 To Year(La_date) + 20: Me.Combobox_Annee.AddItem i: Next
    SpinButton_Mois.Value = Month(La_date)
    SpinButton_Annee.Value = Year(La_date)
    Reload_Clavier
    Me.Repaint
End Sub
Private Sub BT_Aujourdhui_Click()
    SpinButton_Mois.Value = Month(Date)
    SpinButton_Annee.Value = Year(Date)
    Reload_Clavier
    Me.Repaint
End Sub
Private Sub Combobox_Mois_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    KeyAscii = 0
End Sub
Private Sub Combobox_Mois_Change()
    With Combobox_Mois
        SpinButton_Mois.Value = Combobox_Mois.ListIndex + 1
        Me.Reload_Clavier
    End With
End Sub
Private Sub SpinButton_Mois_Change(): 'Evenement combobox et spinbutton des mois et des années
    With SpinButton_Mois
        If Combobox_Annee > 1901 Then
            If .Value = 0 Then
                .Value = 12
                Combobox_Annee.Value = Combobox_Annee.Value - 1
            End If
        End If
        If .Value = 13 Then
            .Value = 1
            Combobox_Annee.Value = Combobox_Annee.Value + 1
        End If
        Combobox_Mois.ListIndex = .Value - 1
    End With
End Sub
Private Sub Combobox_Annee_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    KeyAscii = 0
End Sub
Private Sub Combobox_Annee_Change()
    If Combobox_Annee >= 1901 Then
        With Combobox_Annee
            SpinButton_Annee.Value = Combobox_Annee.Value
            Me.Reload_Clavier
        End With
    End If
End Sub
Private Sub SpinButton_Annee_Change()
    Combobox_Annee.Value = SpinButton_Annee.Value
End Sub
'Mise ajour du clavier
Public Sub Reload_Clavier()
Dim i As Long
Dim La_Date_clavier As Date
Dim Dimanche_avant_la_date As Date
Dim Jour_de_la_date As Variant
Dim Date_Mois_Paire As Variant
    If Combobox_Mois.Value = "" Or Combobox_Annee.Value = "" Then Exit Sub
'Date de départ pour le mappage du clavier
    If IsDate(Obj) Then 'Si une date remontée
        If Day(Obj.Value) > Day(Date) + 7 Then  'Si le jour de la date remontée est plus grand que le jour du jour+7 jours
            La_Date_clavier = Obj.Value - 14    'Le départ du calendrier sera 2 semaines avant la date remontée cela permet de voir
                                                'la date d'aujourd'hui lors du clique sur le bouton aujourd'hui
        Else
            La_Date_clavier = Obj.Value         'Remonte la date existante dans le calendrier
        End If
    Else
        La_Date_clavier = Date 'Si pas de date = Aujourd'hui
    End If
    Jour_de_la_date = Day(La_Date_clavier)
    La_Date_clavier = DateSerial(Me.Combobox_Annee, Me.Combobox_Mois.ListIndex + 1, Jour_de_la_date)
    Dimanche_avant_la_date = La_Date_clavier - (Weekday(La_Date_clavier, vbMonday) + 7) 'Premier jour un dimanche pour le bouton j0 caché
'Mappage des jours
    Me.Controls("j0").Tag = CDate(Dimanche_avant_la_date) 'Bouton j0 caché pour que le bouton j1 soit dans la boucle des couleurs
    For i = 1 To 119
        With Me.Controls("j" & i)
            Jour_de_la_date = format(CDate(Me.Controls("j" & (i - 1)).Tag) + 1, "d")
            .Tag = CDate(Me.Controls("j" & (i - 1)).Tag) + 1
            .Caption = Day(.Tag)
            .ControlTipText = format(CDate(Me.Controls("j" & (i - 1)).Tag) + 1, "dd mmmm yyyy") 'Affiche la date au passage de la souris
    'Colorer la police du weekend
            If Weekday(CDate(.Tag)) = 7 Or Weekday(CDate(.Tag)) = 1 Then
                .ForeColor = Couleur_Police_Weekend
            Else
    'Colorer la police du mois en cours
                If Month(CDate(.Tag)) = Month(Date) Then
                    .ForeColor = Couleur_Police_Mois_Actuel
                Else
    'Colorer la police par défaut
                    .ForeColor = Couleur_Police_Defaut
                End If
            End If
    'Colorer les boutons selon les jours fériés, les vacances, aujourd'hui et la date remontée
            .BackColor = Couleur_bouton(i)
        End With
    Next
'Mappage des mois
    Me.Controls("Mois0").Tag = CDate(Dimanche_avant_la_date) - 6 'Bouton Mois0 caché pour que le bouton Mois1 soit dans la boucle pour les couleurs
    For i = 1 To 17
        With Me.Controls("Mois" & i)
            .Tag = CDate(Me.Controls("Mois" & (i - 1)).Tag) + 7
            .Caption = format(.Tag, "mmm")
            .ControlTipText = CDate(.Tag) 'Affiche la date au passage de la souris
    'Colorer les boutons des mois paires
            If Mid(CDate(.Tag), 4, 2) Mod 2 = 0 Then 'Diviser le mois par 2 si le résultat est = à 0 le mois est paire
                .BackColor = Couleur_BT_Mois_Paire
            Else
                .BackColor = &HE0E0E0
            End If
    'Colorer la police du mois en cours
            If Month(CDate(.Tag)) = Month(Date) Then
                .ForeColor = Couleur_Police_Mois_Actuel
            Else
                .ForeColor = Couleur_Police_Defaut
            End If
        End With
    Next
'Mappage des semaines
    Me.Controls("sem0").Tag = CDate(Dimanche_avant_la_date) - 6 'Bouton sem0 caché pour que le bouton sem1 soit dans la boucle pour les couleurs
    For i = 1 To 17
        With Me.Controls("sem" & i)
            .Tag = CDate(Me.Controls("sem" & (i - 1)).Tag) + 7
            .Caption = WeekNoIso(CDate(.Tag))
            .ControlTipText = CDate(.Tag) 'Affiche la date au passage de la souris
    'Colorer les boutons des semaines comme les boutons des mois
            .BackColor = Me.Controls("Mois" & i).BackColor
    'Colorer la police du mois en cours
            If Month(CDate(.Tag)) = Month(Date) Then
                .ForeColor = Couleur_Police_Mois_Actuel
            Else
                .ForeColor = Couleur_Police_Defaut
            End If
        End With
    Next
End Sub
Private Function Couleur_bouton(i)
Dim La_date_Reload As Date
Dim paques As Date
Dim ctrlJ As Object
Dim Date_Remontee As Variant
Dim Date_Début_Vacances As Variant
Dim Date_Mois_Paire As Variant
Dim Date_Mois_Actuelle As Variant
    Set ctrlJ = Me.Controls("J" & i)
    La_date_Reload = CDate(Me.Controls("J" & i).Tag)
    paques = CDate(((Round(DateSerial(Combobox_Annee.Value, 4, (234 - 11 * (Combobox_Annee.Value Mod 19)) Mod 30) / 7, 0) * 7) - 6))
    Couleur_bouton = Couleur_BT_Defaut
'Colorer le bouton de la date remontée
    If IsDate(Ancienne_Valeur) Then
        Date_Remontee = Ancienne_Valeur
    Else
        Date_Remontee = 0
    End If
'Colorer le bouton du mois paire
    If Mid(La_date_Reload, 4, 2) Mod 2 = 0 Then 'Diviser le Mois par 2 si le résultat est = à 0 le mois est paire
        Date_Mois_Paire = La_date_Reload
    Else
        Date_Mois_Paire = 0
    End If
    Date_Début_Vacances = CDate("21/07/23") 'Début des vacances d'été
'Colorer les jours fériés, les vacances, aujourd'hui et la date remontée
    Select Case True
        Case La_date_Reload = CDate(Date_Remontee): Couleur_bouton = Couleur_BT_Date_Remontee: ctrlJ.ControlTipText = "Date saisie - " & La_date_Reload
        Case La_date_Reload = Date: Couleur_bouton = Couleur_BT_Aujourdhui: ctrlJ.ControlTipText = "Aujourd'hui - " & La_date_Reload
        Case La_date_Reload = CDate("01/01/" & Combobox_Annee): Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Jour de l'an - " & La_date_Reload
        Case La_date_Reload = CDate("02/01/" & Combobox_Annee): Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Vaud et Jura - " & La_date_Reload
        Case La_date_Reload = CDate("01/01/" & Combobox_Annee + 1): Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Jour de l'an - " & La_date_Reload 'Année suivante
        Case La_date_Reload = CDate("02/01/" & Combobox_Annee + 1): Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Vaud et Jura - " & La_date_Reload 'Année suivante
        Case La_date_Reload = paques - 2: Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Vendredi saint - " & La_date_Reload
        Case La_date_Reload = paques: Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Pâques - " & La_date_Reload
        Case La_date_Reload = paques + 1: Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Lundi de Pâques - " & La_date_Reload
        Case La_date_Reload = CDate("01/05/" & Combobox_Annee.Value): Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Fête du travail - " & La_date_Reload
        Case La_date_Reload = paques + 39: Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Ascension - " & La_date_Reload
        Case La_date_Reload = paques + 40: Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Pont de l'ascension - " & La_date_Reload
        Case La_date_Reload = paques + 49: Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Pentecôte - " & La_date_Reload
        Case La_date_Reload = paques + 50: Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Lundi de Pentecôte - " & La_date_Reload
        Case La_date_Reload = CDate("01/08/" & Combobox_Annee.Value): Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Fête Nationale - " & La_date_Reload
        Case La_date_Reload = CDate("22/09/" & Combobox_Annee) - Weekday("22/09/" & Combobox_Annee.Value, 2): Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Jeûne Fédéral - " & La_date_Reload
        Case La_date_Reload = CDate("22/09/" & Combobox_Annee) - Weekday("22/09/" & Combobox_Annee.Value, 2) + 1: Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Lundi du Jeûne - " & La_date_Reload
        Case La_date_Reload = CDate("25/12/" & Combobox_Annee): Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Noel - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 1): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 2): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 3): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 4): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 5): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 6): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 7): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 8): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 9): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 10): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 11): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 12): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 13): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 14): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 15): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 16): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 17): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 18): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 19): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 20): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 21): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 22): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 23): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Mois_Paire): Couleur_bouton = Couleur_BT_Mois_Paire
    End Select
End Function
Private Sub BT_Fermer_Click() 'Ferme avec l'ancienne valeur
    Me.valeur = Ancienne_Valeur
    Me.Hide 'unload dans la fonction ShowX
End Sub
Private Sub BT_Effacer_Click() 'Efface et ferme avec la valeur à rien
    Me.valeur = ""
    Me.Hide 'unload dans la fonction ShowX
End Sub
Function WeekNoIso(MyDate As Date) As Integer
    WeekNoIso = Evaluate("isoweeknum(" & CLng(MyDate) & ")") 'N° semaine EURO
End Function
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = 0 Then
        Me.valeur = Ancienne_Valeur
        Cancel = True
        Me.Hide 'unload dans la fonction ShowX
    Else
        Cancel = False
    End If
End Sub

**goninph** · 22/03/2023, 20h41

Suppression des boutons fictifs j0 m0 et s0

J'espère un peu moins "spaghetti" pour reprendre l'expression @deedolith

Pour ma part tout est compréhensible et ça fonctionne à merveille dans tous mes outils, y compris dans Outlook

Merci à tous pour vos multiples conseils

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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
Option Explicit
'A placer dans la feuille
'Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'Dim DateFormats, DF 'Afficher le calendrier selon le format de la cellule
'    DateFormats = Array("ddd dd/mm/yy") 'Format dans la cellule jjj jj.mm.aa
'    For Each DF In DateFormats
'        If DF = Target.NumberFormat Then
'            Target = USF_Calendar.ShowX(Target)
'            Cancel = True 'Worksheet_BeforeDoubleClick Cancel = True permet de resortir du mode édition F2)
'        End If
'    Next
'End Sub
'A copier dans un userform
'''''''Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'''''''    TextBox1 = USF_Calendar.ShowX(TextBox1)
'''''''End Sub
'Sur la base du calendrier de patricktoulon/exceldownload/Version:4.1.9 maj du 26.11.2020/Adapté par Goninph 19.03.2023
'https://www.developpez.net/forums/d2147600/logiciels/microsoft-office/excel/macros-vba-excel/excel-vba-datepicker-mso365-numeros-semaines/#post11929194
Const Couleur_BT_Defaut As Variant = &HE0E0E0
Const Couleur_BT_Aujourdhui As Variant = &HC0FFFF
Const Couleur_BT_Ferie As Variant = &HC0C0FF
Const Couleur_BT_Date_Remontee As Variant = &H80C0FF
Const Couleur_BT_Vacances As Variant = &HFFFF80
Const Couleur_BT_Mois_Paire As Variant = &HFFFFFF
Const Couleur_Police_Defaut As Variant = &H0&
Const Couleur_Police_Mois_Actuel As Variant = &HFF0000
Const Couleur_Police_Weekend As Variant = &HC0C0C0
Public Obj As Object
Public WithEvents Bout As MSForms.CommandButton   'map pour 42 bouton
Public lance As Boolean
Public La_date As Variant
Public valeur As Variant
Public objX As Object
Public Ancienne_Valeur As Variant
Public Nouvelle_Date As Variant
Private clavier(118) As New USF_Calendar    'tableau d'instance de l'userform
Public Function ShowX(Optional objX As Object)
Dim Forme As Variant
    Set Obj = objX 'les variables argument doivent etre instruites avant le show IMPORTANT!!!!!!!!!!
    lance = True
    'Option de placement
    Me.startupposition = 0
    Me.Left = Windows.Application.Left + Windows.Application.Width / 2 - Me.Width / 2
    Me.Top = Windows.Application.Top + Windows.Application.Height / 2 - Me.Height / 2
    'Ouvre le calendrier
    Me.Show
    'Redonne la date lors du clique sur un jour du calendrier
    If IsDate(Nouvelle_Date) Then
        If TypeName(Obj) = "Range" Then 'Vérifier si cette une cellule ou un contrôle
            valeur = Nouvelle_Date
            ShowX = valeur 'Donne la date dans une cellule
        Else
            valeur = format(Nouvelle_Date, Forme)
            ShowX = valeur 'Donne la date dans un contrôle
        End If
    Else
        ShowX = valeur 'Redonne la valeur si c'est du texte ou vide
    End If
    Unload Me
End Function
Private Sub Bout_DblClick(ByVal Cancel As MSForms.ReturnBoolean) 'Evenement unique pour 42 boutons
    With USF_Calendar
        .Nouvelle_Date = CDate(Bout.Tag)
        .Hide 'unload dans la fonction ShowX
    End With
End Sub
Private Sub UserForm_Activate()
Dim i As Long
    If Not lance Then Unload Me: MsgBox " c'est une boite de dialogue plus un userform" & vbCrLf & "il se lance uniquememt par une de ses deux fonctions " & vbCrLf & """ShowX"" ou   ""ShowTopLeft""": Exit Sub
    BT_Aujourdhui.Caption = "Aujourd'hui " & format(Date, "dddd dd.mm.yyyy")
    config
    Me.Caption = "Calendrier Suisse et fériés vaudois - V.2023_03_22"
    For i = 1 To 118: Set clavier(i).Bout = Me.Controls("j" & i): Next    'mappage pour evenement unique (42 boutons) (intra userform sans module classe)
    Me.Repaint
End Sub
Sub config()
Dim Listdays As Variant
Dim i As Long
    Me.Combobox_Mois.List = Split("janvier,février,mars,avril,mai,juin,juillet,août,septembre,octobre,novembre,décembre", ",")
    Ancienne_Valeur = Obj.Value
    'Remonte la date existante dans le calendrier
    If Not Obj Is Nothing Then
        If IsDate(Obj) Then
            If Obj.Value < CDate("01.01.1901") Then
                La_date = CDate("01.01.1901")
            Else
                La_date = Obj.Value 'si il y a une date existante
            End If
        Else
            La_date = Date      'si il n'y pas de date existante
        End If
    End If
    Me.Combobox_Mois.ListIndex = Month(La_date) - 1
    For i = 2023 To Year(La_date) + 20: Me.Combobox_Annee.AddItem i: Next
    SpinButton_Mois.Value = Month(La_date)
    SpinButton_Annee.Value = Year(La_date)
    Reload_Clavier
    Me.Repaint
End Sub
Private Sub BT_Aujourdhui_Click()
    SpinButton_Mois.Value = Month(Date)
    SpinButton_Annee.Value = Year(Date)
    Reload_Clavier
    Me.Repaint
End Sub
Private Sub Combobox_Mois_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    KeyAscii = 0
End Sub
Private Sub Combobox_Mois_Change()
    With Combobox_Mois
        SpinButton_Mois.Value = Combobox_Mois.ListIndex + 1
        Me.Reload_Clavier
    End With
End Sub
Private Sub SpinButton_Mois_Change(): 'Evenement combobox et spinbutton des mois et des années
    With SpinButton_Mois
        If Combobox_Annee > 1901 Then
            If .Value = 0 Then
                .Value = 12
                Combobox_Annee.Value = Combobox_Annee.Value - 1
            End If
        End If
        If .Value = 13 Then
            .Value = 1
            Combobox_Annee.Value = Combobox_Annee.Value + 1
        End If
        Combobox_Mois.ListIndex = .Value - 1
    End With
End Sub
Private Sub Combobox_Annee_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    KeyAscii = 0
End Sub
Private Sub Combobox_Annee_Change()
    If Combobox_Annee >= 1901 Then
        With Combobox_Annee
            SpinButton_Annee.Value = Combobox_Annee.Value
            Me.Reload_Clavier
        End With
    End If
End Sub
Private Sub SpinButton_Annee_Change()
    Combobox_Annee.Value = SpinButton_Annee.Value
End Sub
'Mise ajour du clavier
Public Sub Reload_Clavier()
Dim i As Long
Dim La_Date_clavier As Date
Dim Dimanche_avant_la_date As Date
Dim Jour_de_la_date As Variant
Dim Date_Mois_Paire As Variant
    If Combobox_Mois.Value = "" Or Combobox_Annee.Value = "" Then Exit Sub
'Date de départ pour le mappage du clavier
    If IsDate(Obj) Then 'Si une date remontée
        If Day(Obj.Value) > Day(Date) + 7 Then  'Si le jour de la date remontée est plus grand que le jour du jour+7 jours
            La_Date_clavier = Obj.Value - 14    'Le départ du calendrier sera 2 semaines avant la date remontée cela permet de voir
                                                'la date d'aujourd'hui lors du clique sur le bouton aujourd'hui
        Else
            La_Date_clavier = Obj.Value         'Remonte la date existante dans le calendrier
        End If
    Else
        La_Date_clavier = Date 'Si pas de date = Aujourd'hui
    End If
    Jour_de_la_date = Day(La_Date_clavier)
    La_Date_clavier = DateSerial(Me.Combobox_Annee, Me.Combobox_Mois.ListIndex + 1, Jour_de_la_date)
    Dimanche_avant_la_date = La_Date_clavier - (Weekday(La_Date_clavier, vbMonday) + 7) 'Premier jour un dimanche pour le bouton j0 caché
'Mappage des jours
    For i = 1 To 118
        With Me.Controls("j" & i)
            .Tag = CDate(Dimanche_avant_la_date) + i
            .Caption = Day(.Tag)
            .ControlTipText = format(CDate(.Tag), "dd mmmm yyyy") 'Affiche la date au passage de la souris
    'Colorer la police du weekend
            If Weekday(CDate(.Tag)) = 7 Or Weekday(CDate(.Tag)) = 1 Then
                .ForeColor = Couleur_Police_Weekend
            Else
    'Colorer la police du mois en cours
                If Month(CDate(.Tag)) = Month(Date) Then
                    .ForeColor = Couleur_Police_Mois_Actuel
                Else
    'Colorer la police par défaut
                    .ForeColor = Couleur_Police_Defaut
                End If
            End If
    'Colorer les boutons selon les jours fériés, les vacances, aujourd'hui et la date remontée
            .BackColor = Couleur_bouton(i)
        End With
    Next
'Mappage des mois
    For i = 1 To 17
        With Me.Controls("m" & i)
            .Tag = (CDate(Dimanche_avant_la_date) - 6) + (i * 7)
            .Caption = format(.Tag, "mmm")
            .ControlTipText = CDate(.Tag) 'Affiche la date au passage de la souris
    'Colorer les boutons des mois paires
            If Mid(CDate(.Tag), 4, 2) Mod 2 = 0 Then 'Diviser le mois par 2 si le résultat est = à 0 le mois est paire
                .BackColor = Couleur_BT_Mois_Paire
            Else
                .BackColor = &HE0E0E0
            End If
    'Colorer la police du mois en cours
            If Month(CDate(.Tag)) = Month(Date) Then
                .ForeColor = Couleur_Police_Mois_Actuel
            Else
                .ForeColor = Couleur_Police_Defaut
            End If
        End With
    Next
'Mappage des semaines
    For i = 1 To 17
        With Me.Controls("s" & i)
            .Tag = (CDate(Dimanche_avant_la_date) - 6) + (i * 7)
            .Caption = WeekNoIso(CDate(.Tag))
            .ControlTipText = CDate(.Tag) 'Affiche la date au passage de la souris
    'Colorer les boutons des semaines comme les boutons des mois
            .BackColor = Me.Controls("m" & i).BackColor
    'Colorer la police du mois en cours
            If Month(CDate(.Tag)) = Month(Date) Then
                .ForeColor = Couleur_Police_Mois_Actuel
            Else
                .ForeColor = Couleur_Police_Defaut
            End If
        End With
    Next
End Sub
Private Function Couleur_bouton(i)
Dim La_date_Reload As Date
Dim paques As Date
Dim ctrlJ As Object
Dim Date_Remontee As Variant
Dim Date_Début_Vacances As Variant
Dim Date_Mois_Paire As Variant
Dim Date_Mois_Actuelle As Variant
    Set ctrlJ = Me.Controls("J" & i)
    La_date_Reload = CDate(Me.Controls("J" & i).Tag)
    paques = CDate(((Round(DateSerial(Combobox_Annee.Value, 4, (234 - 11 * (Combobox_Annee.Value Mod 19)) Mod 30) / 7, 0) * 7) - 6))
    Couleur_bouton = Couleur_BT_Defaut
'Colorer le bouton de la date remontée
    If IsDate(Ancienne_Valeur) Then
        Date_Remontee = Ancienne_Valeur
    Else
        Date_Remontee = 0
    End If
'Colorer le bouton du mois paire
    If Mid(La_date_Reload, 4, 2) Mod 2 = 0 Then 'Diviser le Mois par 2 si le résultat est = à 0 le mois est paire
        Date_Mois_Paire = La_date_Reload
    Else
        Date_Mois_Paire = 0
    End If
    Date_Début_Vacances = CDate("21/07/23") 'Début des vacances d'été
'Colorer les jours fériés, les vacances, aujourd'hui et la date remontée
    Select Case True
        Case La_date_Reload = CDate(Date_Remontee): Couleur_bouton = Couleur_BT_Date_Remontee: ctrlJ.ControlTipText = "Date saisie - " & La_date_Reload
        Case La_date_Reload = Date: Couleur_bouton = Couleur_BT_Aujourdhui: ctrlJ.ControlTipText = "Aujourd'hui - " & La_date_Reload
        Case La_date_Reload = CDate("01/01/" & Combobox_Annee): Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Jour de l'an - " & La_date_Reload
        Case La_date_Reload = CDate("02/01/" & Combobox_Annee): Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Vaud et Jura - " & La_date_Reload
        Case La_date_Reload = CDate("01/01/" & Combobox_Annee + 1): Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Jour de l'an - " & La_date_Reload 'Année suivante
        Case La_date_Reload = CDate("02/01/" & Combobox_Annee + 1): Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Vaud et Jura - " & La_date_Reload 'Année suivante
        Case La_date_Reload = paques - 2: Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Vendredi saint - " & La_date_Reload
        Case La_date_Reload = paques: Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Pâques - " & La_date_Reload
        Case La_date_Reload = paques + 1: Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Lundi de Pâques - " & La_date_Reload
        Case La_date_Reload = CDate("01/05/" & Combobox_Annee.Value): Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Fête du travail - " & La_date_Reload
        Case La_date_Reload = paques + 39: Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Ascension - " & La_date_Reload
        Case La_date_Reload = paques + 40: Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Pont de l'ascension - " & La_date_Reload
        Case La_date_Reload = paques + 49: Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Pentecôte - " & La_date_Reload
        Case La_date_Reload = paques + 50: Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Lundi de Pentecôte - " & La_date_Reload
        Case La_date_Reload = CDate("01/08/" & Combobox_Annee.Value): Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Fête Nationale - " & La_date_Reload
        Case La_date_Reload = CDate("22/09/" & Combobox_Annee) - Weekday("22/09/" & Combobox_Annee.Value, 2): Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Jeûne Fédéral - " & La_date_Reload
        Case La_date_Reload = CDate("22/09/" & Combobox_Annee) - Weekday("22/09/" & Combobox_Annee.Value, 2) + 1: Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Lundi du Jeûne - " & La_date_Reload
        Case La_date_Reload = CDate("25/12/" & Combobox_Annee): Couleur_bouton = Couleur_BT_Ferie: ctrlJ.ControlTipText = "Noel - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 1): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 2): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 3): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 4): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 5): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 6): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 7): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 8): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 9): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 10): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 11): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 12): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 13): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 14): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 15): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 16): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 17): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 18): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 19): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 20): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 21): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 22): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Début_Vacances + 23): Couleur_bouton = Couleur_BT_Vacances: ctrlJ.ControlTipText = "Vacances - " & La_date_Reload
        Case La_date_Reload = CDate(Date_Mois_Paire): Couleur_bouton = Couleur_BT_Mois_Paire
    End Select
End Function
Private Sub BT_Fermer_Click() 'Ferme avec l'ancienne valeur
    Me.valeur = Ancienne_Valeur
    Me.Hide 'unload dans la fonction ShowX
End Sub
Private Sub BT_Effacer_Click() 'Efface et ferme avec la valeur à rien
    Me.valeur = ""
    Me.Hide 'unload dans la fonction ShowX
End Sub
Function WeekNoIso(MyDate As Date) As Integer
    WeekNoIso = Evaluate("isoweeknum(" & CLng(MyDate) & ")") 'N° semaine EURO
End Function
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = 0 Then
        Me.valeur = Ancienne_Valeur
        Cancel = True
        Me.Hide 'unload dans la fonction ShowX
    Else
        Cancel = False
    End If
End Sub

**deedolith** · 22/03/2023, 23h21

C'est encore frais dans ta tête, donc tu comprends tout.
Dans 3 ou 6 mois, ce ne sera probablement plus le cas, et de notre point de vue extérieur, ce n'est surtout pas le cas.

Mon plus gros reproche est que lorsque l'on instancie un calendrier, ce dernier en instancie un calendrier par bouton. C'est un énorme gaspillage de ressources.
Le second reproche, est le manque de versatilité, tu l'as expérimenté toi même, pour répondre a tes besoins (vacances / congés / jours fériés suisse), tu as du retoucher le code. Ca ne devrait pas être le cas.
Je passe sur la qualité de code, il y a trop à redire.

**goninph** · 23/03/2023, 10h18

Bonjour,

Je n'ai pas compris votre remarque

Mon plus gros reproche est que lorsque l'on instancie un calendrier, ce dernier en instancie un calendrier par bouton. C'est un énorme gaspillage de ressources.

Les boutons devraient être remplacés par quel autre contrôle ?

Excel vba DatePicker MSO365 avec numéros de semaines

Macros et VBA Excel

Discussions similaires

Partager

Partager