Discussion :

[goninph]

Bonjour,

Ce calendrier est vraiment génial, mais il a un défaut, il lui manque les numéros de semaines

En son temps, je l'avais téléchargé à cette adresse, mais elle n'est plus valable

Est-ce que l'un d'entre vous aurait les connaissances pour modifier le code pour lui ajouter les numéros de semaines ?

Auriez-vous un DatePicker (VBA) avec les numéros de semaines compatible avec la dernière version Excel ?

https://sites.google.com/site/e90e50...lendar-Control


Userform : USF_Calendar_Activecell

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
Option Explicit 'UserForm with Frame1
Private WithEvents USF_Calendar_Activecell As cCalendar
Private Sub Label_Today_Click()
    USF_Calendar_Activecell.Value = Date
End Sub
Private Sub UserForm_Initialize()
    Me.Left = Application.Left + Application.Width / 2 - Me.Width / 2 'Pour centrer sur l'application Application.Left + Application.Width / 2 - Me.Width / 2
    Me.Top = Application.Top + Application.Height / 2 - Me.Height / 2 'Pour centrer sur l'application Application.Top + Application.Height / 2 - Me.Height / 2
    Set USF_Calendar_Activecell = New cCalendar
    USF_Calendar_Activecell.Add_Calendar_into_Frame Me.Frame1
    Me.Label_Today = Date
End Sub
Private Sub UserForm_Activate()
    If Not IsDate(ActiveCell) Then
        USF_Calendar_Activecell.Value = Date 'Si cellule vide ouvre le calendrier à la date du jour
    Else
        USF_Calendar_Activecell.Value = CDate(ActiveCell) 'Ouvre le calendrier à la date indiquée
    End If
End Sub
Private Sub USF_Calendar_Activecell_DblClick()
    If USF_Calendar_Activecell.Value < Now - 1 Then
        MsgBox "La date est dans le passé.", vbExclamation, "! Oups ! Action interrompue"
    Else
        ActiveCell = USF_Calendar_Activecell.Value
        Unload Me
    End If
End Sub
Private Sub Userform_QueryClose(Cancel As Integer, CloseMode As Integer)
    Set USF_Calendar_Activecell = Nothing
End Sub
Private Sub Btn_Ferme_Click()
   Unload Me
End Sub
Private Sub BtnEffacerLaDate_Click()
    Unload Me
    ActiveCell = ""
'    Range("A1").Select
End Sub

Le module : cCalendar

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
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
Option Explicit
 
'###############################################################
'# Calendar Control Class v2.0.0                               #
'#                                                             #
'# Team authors:                                               #
'# Krisztina Szabó                                             #
'# Gábor Madács                                                #
'# Roberto Mensa (nick r)                                      #
'#                                                             #
'# https://sites.google.com/site/e90e50/calendar-control-class #
'#                                                             #
'#   The FrankensTeam                                          #
'###############################################################
 
'# Event Triggered By Main Object
Public Event AfterUpdate()
Public Event BeforeUpdate(ByRef Cancel As Integer)
Public Event Click()
Public Event DblClick()
Public Event KeyDown( _
    ByVal KeyCode As MSForms.ReturnInteger, _
    ByVal Shift As Integer)
 
'# Members for Main Object
Private WithEvents CBxY As MSForms.ComboBox
Private WithEvents CBxM As MSForms.ComboBox
 
Private CLb As MSForms.Label
Private mDayButtons() As cCalendar
Private mLabelButtons() As cCalendar
 
Private PTitleNewFont As MSForms.NewFont
Private PDayNewFont As MSForms.NewFont
Private PGridNewFont As MSForms.NewFont
'# Members for Button Object
Private WithEvents CmB As MSForms.CommandButton
Private CmBl As MSForms.Label
Private CmBlNum As MSForms.Label
Private mcMain As cCalendar
 
'# For Properties
Private lPFontSize As Long
Private lPMonthLength As calMonthLength
Private lPDayLength As Long
Private bPYearFirst As Boolean
Private lPTitleFontColor As OLE_COLOR
Private lPGridFontColor As OLE_COLOR
Private lPDayFontColor As OLE_COLOR
Private lPFirstDay As calDayOfWeek
Private dValue As Date
Private lPBackColor As OLE_COLOR
Private lPMonth As Long
Private lPYear As Long
Private lPDay As Long
Private lPHeaderBackColor As OLE_COLOR
Private lPUseDefaultBackColors  As Boolean
Private bPVisible As Boolean
Private sPHeight As Single
Private sPWidth As Single
Private sPTop As Single
Private sPLeft As Single
Private lPSaturdayBackColor As OLE_COLOR
Private lPSundayBackColor As OLE_COLOR
Private lPSelectedBackColor As OLE_COLOR
Private lPUnSelectableBackColor As OLE_COLOR
Private sPControlTipText As String
Private bPTabStop As Boolean
Private lPTabIndex As Long
Private sPTag As String
 
Private bPShowDays As Boolean
Private bPShowTitle As Boolean
Private bPShowDateSelectors As Boolean
Private bPValueIsNull As Boolean
Private bPRightToLeft As Boolean
 
Private bPMACFix As Boolean 'Fix MAC transparency errors
Private bPWeekdaySelectable As Boolean
Private bPSaturdaySelectable As Boolean
Private bPSundaySelectable As Boolean
Private bPValueSelectable As Boolean '(Used in buttons too).
 
Private maColoredArrayTable As Variant
 
Private Const cDayFontColorSelected As Long = &H80000012 'Button text - Black
Private Const cDayFontColorInactive As Long = &H80000011 'Disabled text - Dark gray
Private Const cDefaultWidth As Single = 216
Private Const cDefaultHeight As Single = 144
 
Public Enum calDayOfWeek
    dwMonday = 1
    dwTuesday = 2
    dwWednesday = 3
    dwThursday = 4
    dwFriday = 5
    dwSaturday = 6
    dwSunday = 7
End Enum
 
Public Enum calMonthLength '(Used for month and day names too.)
    mlLocalLong = 0 'Local name, long form
    mlLocalShort = 1 'Local name, short form
    mlENLong = 2 'English name, long form
    mlENShort = 3 'English name, short form
End Enum
 
Private Enum ColorCols 'ColoredDateArray fields
    ccColor = 1
    ccFormat = 2
    ccDateList = 3
    ccSelectable = 4
End Enum
 
'################################################
'# Properties for Main object - Not available
 
Public Property Get GridCellEffect() As Long
'Property Blank - not work
'Determines the effect used to display the grid.
End Property
 
Public Property Get GridLinesColor() As OLE_COLOR
'Property Blank - not work
'Determines the color used to display the lines in the grid.
End Property
 
Public Property Get ShowHorizontalGrid() As Boolean
'Property Blank - not work
'Specifies whether the calendar display horizontal gridlines.
End Property
 
Public Property Get ShowVerticalGrid() As Boolean
'Property Blank - not work
'Specifies whether to display vertical gridlines.
End Property
 
Public Property Get HelpContextID() As Long
'Property Blank - not work
'Specifies Help identifier
End Property
 
 
'###########################
'# Properties for Main object
 
Public Property Get Tag() As String
    Tag = sPTag
End Property
 
Public Property Let Tag(sTag As String)
    sPTag = sTag
End Property
 
Public Property Get Parent() As Control
    If bInit Then
        Set Parent = CBxY.Parent.Parent
    Else
        Set Parent = Nothing
    End If
End Property
 
Public Property Get ValueIsNull() As Boolean
    ValueIsNull = bPValueIsNull
End Property
 
Public Property Let ValueIsNull(ByVal bValueIsNull As Boolean)
    bPValueIsNull = bValueIsNull
    If bInit Then
        Value = Value
    End If
End Property
 
Public Property Get ShowTitle() As Boolean
    ShowTitle = bPShowTitle
End Property
 
Public Property Let ShowTitle(ByVal bShowTitle As Boolean)
    bPShowTitle = bShowTitle
    If bInit Then
        CLb.Visible = bPShowTitle
        Call Move
    End If
End Property
 
Public Property Get ShowDays() As Boolean
    ShowDays = bPShowDays
End Property
 
Public Property Let ShowDays(ByVal bShowDays As Boolean)
    Dim i As Long
    bPShowDays = bShowDays
    If bInit Then
        For i = 0 To 6
            mLabelButtons(i).Obj_CmBl.Visible = bShowDays
        Next
        Call Move
    End If
End Property
 
Public Property Get ShowDateSelectors() As Boolean
    ShowDateSelectors = bPShowDateSelectors
End Property
 
Public Property Let ShowDateSelectors(ByVal bShowDateSelectors As Boolean)
    bPShowDateSelectors = bShowDateSelectors
    If bInit Then
        CBxY.Visible = bShowDateSelectors
        CBxM.Visible = bShowDateSelectors
        Call Move
    End If
End Property
 
Public Property Get TabIndex() As Long
    TabIndex = lPTabIndex
End Property
 
Public Property Let TabIndex(ByVal lTabIndex As Long)
    lPTabIndex = lTabIndex
    If bInit Then
        CBxY.Parent.TabIndex = lTabIndex
    End If
End Property
 
Public Property Get TabStop() As Boolean
    TabStop = bPTabStop
End Property
 
Public Property Let TabStop(ByVal bTabStop As Boolean)
    bPTabStop = bTabStop
    If bInit Then
        CBxY.Parent.TabStop = bTabStop
    End If
End Property
 
Public Property Get ControlTipText() As String
    ControlTipText = sPControlTipText
End Property
 
Public Property Let ControlTipText(ByVal sControlTipText As String)
    Dim i As Long
    sPControlTipText = sControlTipText
    If bInit Then
        For i = 0 To 6
            mLabelButtons(i).Obj_CmBl.ControlTipText = sControlTipText
        Next
        For i = 0 To 41
            mDayButtons(i).Obj_Cmb.ControlTipText = sControlTipText
        Next
        CBxM.ControlTipText = sControlTipText
        CBxY.ControlTipText = sControlTipText
        CLb.ControlTipText = sControlTipText
        'CBxY.Parent.ControlTipText = sControlTipText
    End If
End Property
 
Public Property Get GridFont() As MSForms.NewFont
    Set GridFont = PGridNewFont
End Property
 
Public Property Set GridFont(ByRef clGridNewFont As MSForms.NewFont)
    Set PGridNewFont = clGridNewFont
End Property
 
Public Property Get DayFont() As MSForms.NewFont
    Set DayFont = PDayNewFont
End Property
 
Public Property Set DayFont(ByRef clDayNewFont As MSForms.NewFont)
    Set PDayNewFont = clDayNewFont
End Property
 
Public Property Get TitleFont() As MSForms.NewFont
    Set TitleFont = PTitleNewFont
End Property
 
Public Property Set TitleFont(ByRef clTitleNewFont As MSForms.NewFont)
    Set PTitleNewFont = clTitleNewFont
End Property
 
Public Property Get Visible() As Boolean
    Visible = bPVisible
End Property
 
Public Property Let Visible(ByVal bVisible As Boolean)
    bPVisible = bVisible
    If bInit Then
        CBxY.Parent.Visible = bVisible
    End If
End Property
 
Public Property Get Left() As Single
    Left = sPLeft
End Property
 
Public Property Let Left(ByVal sLeft As Single)
    sPLeft = sLeft
    If bInit Then
        CBxY.Parent.Left = sLeft
    End If
End Property
 
Public Property Get Top() As Single
    Top = sPTop
End Property
 
Public Property Let Top(ByVal ssTop As Single)
    sPTop = ssTop
    If bInit Then
        CBxY.Parent.Top = ssTop
    End If
End Property
 
Public Property Get Height() As Single
    Height = sPHeight
End Property
 
Public Property Let Height(ByVal sHeight As Single)
    sPHeight = sHeight
    If bInit Then
        CBxY.Parent.Height = sHeight
        Call Move
    End If
End Property
 
 
Public Property Get Width() As Single
    Width = sPWidth
End Property
 
Public Property Let Width(ByVal sWidth As Single)
    'sWidth = Zero_Negative_Value(sWidth)
    sPWidth = sWidth
    If bInit Then
        CBxY.Parent.Width = sWidth
        Call Move
    End If
End Property
 
Public Property Get BackColor() As OLE_COLOR
    BackColor = lPBackColor
End Property
 
Public Property Let BackColor(ByVal lBackColor As OLE_COLOR)
    lPBackColor = lBackColor
    If bInit Then
        CBxY.Parent.BackColor = lBackColor
    End If
End Property
 
Public Property Get HeaderBackColor() As OLE_COLOR
    HeaderBackColor = lPHeaderBackColor
End Property
 
Public Property Let HeaderBackColor(ByVal lHeaderBackColor As OLE_COLOR)
    lPHeaderBackColor = lHeaderBackColor
    UseDefaultBackColors = False
End Property
 
Public Property Get UseDefaultBackColors() As Boolean
    UseDefaultBackColors = lPUseDefaultBackColors
End Property
 
Public Property Let UseDefaultBackColors(ByVal lUseDefaultBackColors As Boolean)
    lPUseDefaultBackColors = lUseDefaultBackColors
    Call Refresh
End Property
 
Public Property Get SaturdayBackColor() As OLE_COLOR
    SaturdayBackColor = lPSaturdayBackColor
End Property
 
Public Property Let SaturdayBackColor(ByVal lSaturdayBackColor As OLE_COLOR)
    lPSaturdayBackColor = lSaturdayBackColor
    UseDefaultBackColors = False
End Property
 
Public Property Get SundayBackColor() As OLE_COLOR
    SundayBackColor = lPSundayBackColor
End Property
 
Public Property Let SundayBackColor(ByVal lSundayBackColor As OLE_COLOR)
    lPSundayBackColor = lSundayBackColor
    UseDefaultBackColors = False
End Property
 
Public Property Get SelectedBackColor() As OLE_COLOR
    SelectedBackColor = lPSelectedBackColor
End Property
 
Public Property Let SelectedBackColor(ByVal lSelectedBackColor As OLE_COLOR)
    lPSelectedBackColor = lSelectedBackColor
    Call Refresh
End Property
 
Public Property Get UnSelectableBackColor() As OLE_COLOR
    UnSelectableBackColor = lPUnSelectableBackColor
End Property
 
Public Property Let UnSelectableBackColor(ByVal lUnSelectableBackColor As OLE_COLOR)
    lPUnSelectableBackColor = lUnSelectableBackColor
    Call Refresh
End Property
 
Public Property Get SaturdaySelectable() As Boolean
    SaturdaySelectable = bPSaturdaySelectable
End Property
 
Public Property Let SaturdaySelectable(ByVal bSaturdaySelectable As Boolean)
    bPSaturdaySelectable = bSaturdaySelectable
    Call Refresh
End Property
 
Public Property Get SundaySelectable() As Boolean
    SundaySelectable = bPSundaySelectable
End Property
 
Public Property Let SundaySelectable(ByVal bSundaySelectable As Boolean)
    bPSundaySelectable = bSundaySelectable
    Call Refresh
End Property
 
Public Property Get WeekdaySelectable() As Boolean
    WeekdaySelectable = bPWeekdaySelectable
End Property
 
Public Property Let WeekdaySelectable(ByVal bWeekdaySelectable As Boolean)
    bPWeekdaySelectable = bWeekdaySelectable
    Call Refresh
End Property
 
Public Property Get FirstDay() As calDayOfWeek
    FirstDay = lPFirstDay
End Property
 
Public Property Let FirstDay(ByVal vbFirstDay As calDayOfWeek)
    Select Case vbFirstDay
        Case 1 To 7
        Case Else
            vbFirstDay = 1
    End Select
 
    lPFirstDay = vbFirstDay
    If bInit Then
        Call ApplyWeekDayLabelChanges
        Call Refresh
    End If
End Property
 
Public Property Get DayFontColor() As OLE_COLOR
    DayFontColor = lPDayFontColor
End Property
 
Public Property Let DayFontColor(ByVal lFontColor As OLE_COLOR)
    Dim i As Long
 
    lPDayFontColor = lFontColor
    If bInit Then
        For i = 0 To 6
            mLabelButtons(i).Obj_CmBl.ForeColor = lFontColor
        Next
    End If
End Property
 
Public Property Get GridFontColor() As OLE_COLOR
    GridFontColor = lPGridFontColor
End Property
 
Public Property Let GridFontColor(ByVal lFontColor As OLE_COLOR)
    lPGridFontColor = lFontColor
    Call Refresh
End Property
 
Public Property Let TitleFontColor(ByVal lFontColor As OLE_COLOR)
    lPTitleFontColor = lFontColor
    If bInit Then
        CLb.ForeColor = lFontColor
    End If
End Property
 
Public Property Get TitleFontColor() As OLE_COLOR
    TitleFontColor = lPTitleFontColor
End Property
 
Public Property Get Month() As Long
    Month = lPMonth
End Property
 
Public Property Let Month(ByVal lMonth As Long)
    If lMonth = 0 Then
        Value = Empty
    Else
        If lMonth < 0 Then lMonth = lPMonth
        lMonth = fMin(lMonth, 12)
        Value = SumMonthsToDate(dValue, lMonth - lPMonth)
    End If
    lPMonth = lMonth
End Property
 
Public Property Get Year() As Long
    Year = lPYear
End Property
 
Public Property Let Year(ByVal lYear As Long)
    If lYear = 0 Then
        Value = Empty
    Else
        Value = VBA.DateSerial(CheckYear(lYear), VBA.Month(dValue), VBA.Day(dValue))
    End If
    lPYear = lYear
End Property
 
Public Property Get Day() As Long
    Day = lPDay
End Property
 
Public Property Let Day(ByVal lDay As Long)
    If lDay = 0 Then
        Value = Empty
    Else
        If lDay < 0 Then lDay = lPDay
        lDay = fMin(lDay, VBA.Day(VBA.DateSerial(VBA.Year(dValue), VBA.Month(dValue) + 1, 0)))
        Value = VBA.DateSerial(VBA.Year(dValue), VBA.Month(dValue), lDay)
    End If
    lPDay = lDay
End Property
 
Public Property Get Value() As Variant
    If bPValueIsNull Or Not bPValueSelectable Then
        Value = Empty
    Else
        Value = dValue
    End If
End Property
 
Public Property Let Value(ByVal newDate As Variant)
    Dim Cancel As Integer '*** Integer for backward compatibility
 
    If CheckValue(newDate) = False Then newDate = Empty
 
    RaiseEvent BeforeUpdate(Cancel) '(Even if unselectable - for navigation.)
 
    If Cancel = 0 Then 'Not canceled.
 
        If bInit And Not IsEmpty(newDate) Then
            CBxY.ListIndex = VBA.Year(newDate) - 1904
            CBxM.ListIndex = VBA.Month(newDate) - 1
        End If
 
        If (bPValueIsNull = IsEmpty(newDate)) Or (newDate <> dValue) Then
            If Not IsEmpty(newDate) Then
                dValue = newDate
            End If
            bPValueIsNull = IsEmpty(newDate)
 
            Call Refresh
        End If
 
        RaiseEvent AfterUpdate '(Even if unselectable - for navigation.)
    End If
End Property
 
Public Property Get ValueSelectable() As Boolean
    ValueSelectable = bPValueSelectable
End Property
 
Public Property Get DayLength() As calMonthLength
    DayLength = lPDayLength
End Property
 
Public Property Let DayLength(ByVal bDayLength As calMonthLength)
    lPDayLength = bDayLength
    If bInit Then
        Call ApplyWeekDayLabelChanges
    End If
End Property
 
Public Property Get MonthLength() As calMonthLength
    MonthLength = lPMonthLength
End Property
 
Public Property Let MonthLength(ByVal iMonthLength As calMonthLength)
    lPMonthLength = iMonthLength
 
    If bInit Then
        CBxM.List = fMonthName(CLng(iMonthLength))
        Value = Value
    End If
End Property
 
Public Property Get YearFirst() As Boolean
    YearFirst = bPYearFirst
End Property
 
Public Property Let YearFirst(ByVal bYearFirst As Boolean)
    bPYearFirst = bYearFirst
    Call RenderLabel
End Property
 
 
Public Property Get MACFix() As Boolean
    MACFix = bPMACFix
End Property
 
' MAC Fix
'There is no Transparent buttons in Office in MAC.
'Update: Office 2106 in Windows banned the transparent buttons too.
'
'Normal buttons isn't resizable under a certain size - the text leaning out on the bottom.
'We use labes and transparent buttons for make little size buttons.
'
'This feaure turns off the labels.
Public Property Let MACFix(ByVal bMACFix As Boolean)
    Dim i As Long
 
    bPMACFix = bMACFix
    If bInit Then
        For i = 0 To 41
            mDayButtons(i).Obj_CmBl.Visible = Not bPMACFix
            mDayButtons(i).Obj_CmBlNum.Visible = Not bPMACFix
            mDayButtons(i).Obj_Cmb.Visible = True 'ZOrder
        Next
    End If
    Call Refresh
End Property
 
 
Public Property Get RightToLeft() As Boolean
    RightToLeft = bPRightToLeft
End Property
 
Public Property Let RightToLeft(ByVal bRightToLeft As Boolean)
    bPRightToLeft = bRightToLeft
    If bInit Then
        Call ApplyWeekDayLabelChanges
        Call Refresh
    End If
End Property
 
 
'###########################
'# Properties for Day button objects
 
Public Property Set Main(ByVal theMain As cCalendar)
    Set mcMain = theMain
End Property
 
Private Property Get Main() As cCalendar
    Set Main = mcMain
End Property
 
Public Property Get Obj_Cmb() As MSForms.CommandButton
    Set Obj_Cmb = CmB
End Property
 
Public Property Set Obj_Cmb(ByVal vNewValue As MSForms.CommandButton)
    Set CmB = vNewValue
End Property
 
Public Property Get Obj_CmBl() As MSForms.Label
    Set Obj_CmBl = CmBl
End Property
 
Public Property Set Obj_CmBl(ByVal vNewValue As MSForms.Label)
    Set CmBl = vNewValue
End Property
 
Public Property Set Obj_CmBlNum(ByVal vNewValue As MSForms.Label)
    Set CmBlNum = vNewValue
End Property
 
Public Property Get Obj_CmBlNum() As MSForms.Label
    Set Obj_CmBlNum = CmBlNum
End Property
 
Property Let Obj_ValueSelectionEnabled(bSelectable As Boolean)
    If Not mcMain Is Nothing Then
        bPValueSelectable = bSelectable
    End If
End Property
 
Property Get Obj_ValueSelectionEnabled() As Boolean
    If Not mcMain Is Nothing Then
        Obj_ValueSelectionEnabled = bPValueSelectable
    End If
End Property
 
'###########################
'# Public Methods
 
Public Sub AboutBox()
    MsgBox "Calendar Control Class" & vbLf & vbLf & "Autors:" & vbLf & " - r - Original Concept and Base Version" & vbLf & " - Kris - Spirit" & vbLf & " - Gabor - VBA Wizardry and New Features" & vbLf & vbLf & "The FrankensTeam"
End Sub
 
Public Sub Add(ByVal fForm As MSForms.UserForm)
 
    Dim cFrame As MSForms.Frame
    Set cFrame = fForm.Controls.Add("Forms.Frame.1")
 
    With cFrame
        .Width = IIf(sPWidth < 0, cDefaultWidth, sPWidth)
        .Height = IIf(sPHeight < 0, cDefaultHeight, sPHeight)
    End With
 
    Call Add_Calendar_into_Frame(cFrame)
 
End Sub
 
Public Sub Add_Calendar_into_Frame(ByVal cFrame As MSForms.Frame)
    Dim i As Long
    Dim v(199) As Variant
    Dim w As Variant
    Dim dTemp As Date
 
    For i = 0 To 199
        v(i) = CStr(1904 + i)
    Next
 
    With cFrame
        .BackColor = BackColor
        .Caption = ""
        .SpecialEffect = 0
        '.Top = IIf(sPTop = -1, .Top, sPTop)
        '.Left = IIf(sPLeft = -1, .Left, sPLeft)
        '.Width = IIf(sPWidth < 0, .Width, sPWidth)
        '.Height = IIf(sPHeight < 0, .Height, sPHeight)
        .Visible = bPVisible
        'Top = .Top
        'Left = .Left
        'Width = .Width
        'Height = .Height
    End With
 
 
    'Add this first, for proper taborder (Need TabStop.)
    Set CLb = cFrame.Controls.Add("Forms.Label.1")
    Set CBxY = cFrame.Controls.Add("Forms.ComboBox.1")
    Set CBxM = cFrame.Controls.Add("Forms.ComboBox.1")
 
    ReDim mLabelButtons(6)
    ReDim mDayButtons(41)
    w = fWeekdayName(CInt(lPDayLength))
 
    For i = 0 To 6
        Set mLabelButtons(i) = New cCalendar
        Set mLabelButtons(i).Main = Me
        Set mLabelButtons(i).Obj_CmBl = cFrame.Controls.Add("Forms.Label.1")
        With mLabelButtons(i).Obj_CmBl
            .Caption = w(((i + lPFirstDay - 1) Mod 7))
            .ForeColor = DayFontColor
            .TextAlign = fmTextAlignCenter
            .BorderStyle = fmBorderStyleSingle
            .BorderColor = &H80000010 'Button shadow  &H80000015 'Button dark shadow
            '.SpecialEffect = fmSpecialEffectEtched
            If HeaderBackColor = -1 Then
                .BackColor = cDayFontColorSelected 'Dark gray
                .BackStyle = fmBackStyleTransparent
            Else
                .BackColor = HeaderBackColor
                .BackStyle = fmBackStyleOpaque
            End If
        End With
    Next
 
    For i = 0 To 41
        Set mDayButtons(i) = New cCalendar
        Set mDayButtons(i).Main = Me
 
        Set mDayButtons(i).Obj_CmBl = cFrame.Controls.Add("Forms.Label.1")
        With mDayButtons(i).Obj_CmBl 'MAC Fix
            .TextAlign = fmTextAlignCenter
            .Visible = Not bPMACFix
        End With
 
        Set mDayButtons(i).Obj_CmBlNum = cFrame.Controls.Add("Forms.Label.1")
        With mDayButtons(i).Obj_CmBlNum
            .TextAlign = fmTextAlignCenter
            .BackStyle = fmBackStyleTransparent
            .Visible = Not bPMACFix
        End With
 
        Set mDayButtons(i).Obj_Cmb = cFrame.Controls.Add("Forms.CommandButton.1")
        With mDayButtons(i).Obj_Cmb
            .BackStyle = fmBackStyleTransparent 'MAC Problem: No button transparency
        End With
 
        mDayButtons(i).RightToLeft = bPRightToLeft
    Next
 
    With CBxY
        .ListRows = 5
        .List = v
        .ListIndex = VBA.Year(dValue) - 1904
        .ShowDropButtonWhen = fmShowDropButtonWhenFocus
        .font.Bold = True
        .MatchRequired = True
    End With
 
    With CBxM
        .ListRows = 12
        .List = fMonthName(lPMonthLength)
        .ListIndex = VBA.Month(dValue) - 1
        .ShowDropButtonWhen = fmShowDropButtonWhenFocus
        .font.Bold = True
        .MatchRequired = True
    End With
 
    With CLb
        .ForeColor = TitleFontColor
        .TextAlign = fmTextAlignCenter
        .BackStyle = fmBackStyleTransparent
    End With
 
    Call ApplyWeekDayLabelChanges
 
    Call ApplyFontChanges
 
    Call Refresh_Properities
 
    Call Move
 
End Sub
 
Private Sub ApplyWeekDayLabelChanges()
    Dim i As Long
    Dim w
 
    w = fWeekdayName(CInt(lPDayLength))
    For i = 0 To 6
        If bPRightToLeft Then
            mLabelButtons(6 - i).Obj_CmBl.Caption = w((i + lPFirstDay - 1) Mod 7)
        Else
            mLabelButtons(i).Obj_CmBl.Caption = w((i + lPFirstDay - 1) Mod 7)
        End If
    Next
End Sub
 
Private Sub ApplyFontChanges()
    Dim font As MSForms.NewFont
    Dim i As Long
 
    If Not PDayNewFont Is Nothing Then
        For i = 0 To 6
            Call ApplyFont(mLabelButtons(i).Obj_CmBl.font, DayFont)
        Next
    End If
 
    If Not PGridNewFont Is Nothing Then
        For i = 0 To 41
            If Not bPMACFix Then
                Set font = mDayButtons(i).Obj_CmBlNum.font
            Else
                Set font = mDayButtons(i).Obj_Cmb.font
            End If
            Call ApplyFont(font, GridFont)
        Next
    End If
 
    If Not PTitleNewFont Is Nothing Then
        Call ApplyFont(CLb.font, TitleFont)
    End If
 
End Sub
 
Private Sub ApplyFont(fTo As MSForms.NewFont, fFrom As MSForms.NewFont)
 
    If fTo.Bold <> fFrom.Bold Then _
        fTo.Bold = fFrom.Bold
    If fTo.Weight <> fFrom.Weight Then _
        fTo.Weight = fFrom.Weight
    If fTo.Charset <> fFrom.Charset Then _
        fTo.Charset = fFrom.Charset
    If fTo.Italic <> fFrom.Italic Then _
        fTo.Italic = fFrom.Italic
    If fTo.Name <> fFrom.Name Then _
        fTo.Name = fFrom.Name
    If fTo.Size <> fFrom.Size Then _
        fTo.Size = fFrom.Size
    If fTo.Strikethrough <> fFrom.Strikethrough Then _
        fTo.Strikethrough = fFrom.Strikethrough
    If fTo.Underline <> fFrom.Underline Then _
        fTo.Underline = fFrom.Underline
 
End Sub
Public Sub Move( _
        Optional vLeft, _
        Optional vTop, _
        Optional vWidth, _
        Optional vHeight, _
        Optional vLayout)
 
    Dim i As Long, l As Currency, b As Currency, lc As Currency, bc As Currency
    Dim t As Long, b_ym As Currency, b_combo_m As Currency
 
    Const h_combo As Long = 16
    Const b_combo_y As Long = 42
    b_combo_m = IIf(lPMonthLength = mlENShort Or lPMonthLength = mlLocalShort, 42, 66) 'mlLocalShort 42, 66
    b_ym = b_combo_y + 2 + b_combo_m
 
    If bInit Then
        t = IIf(ShowDays, 7, 6)
 
        With CBxY.Parent 'Frame
            sPTop = IIf(IsMissing(vTop), IIf(Top = -1, .Top, Top), vTop)
            sPLeft = IIf(IsMissing(vLeft), IIf(Left = -1, .Left, Left), vLeft)
            sPHeight = IIf(IsMissing(vHeight), IIf(Height = -1, .Height, Height), vHeight)
            sPWidth = IIf(IsMissing(vWidth), IIf(Width = -1, .Width, Width), vWidth)
 
            l = Height
            b = Width
            l = Zero_Negative_Value(l - IIf(ShowTitle Or ShowDateSelectors, h_combo, 0) - 1)
            lc = CCur(l / t)
            bc = CCur(b / 7)
            b = bc * 7
        End With
 
        If ShowTitle Then
            With CLb
                .Width = Zero_Negative_Value(IIf(ShowDateSelectors, b - b_ym, b))
                .Height = h_combo
                .Left = 0
            End With
        End If
 
        If ShowDateSelectors Then
            With CBxY
                .Width = b_combo_y
                .Height = h_combo
                .Left = IIf(ShowTitle, CLb.Width, Int((b - b_ym) / 2)) + _
                       IIf(YearFirst, 0, b_combo_m + 2)
            End With
 
            With CBxM
                .Width = b_combo_m
                .Height = h_combo
                .Left = IIf(ShowTitle, CLb.Width, Int((b - b_ym) / 2)) + _
                       IIf(YearFirst, b_combo_y + 2, 0)
            End With
        End If
        If ShowDays Then
            For i = 0 To 6
                With mLabelButtons(i).Obj_CmBl
                    .Top = IIf(ShowTitle Or ShowDateSelectors, h_combo + 2, 0)
                    .Left = (i Mod 7) * bc - IIf(i > 0, 1, 0)
                    .Height = lc
                    .Width = bc + IIf(i > 0, 1, 0)
                End With
            Next
        End If
        For i = 0 To 41
            With mDayButtons(i).Obj_Cmb
                .Top = Int(i / 7) * lc + _
                       IIf(ShowTitle Or ShowDateSelectors, h_combo + 2, 0) + _
                       IIf(ShowDays, lc, 0)
                .Left = (i Mod 7) * bc
                .Height = lc
                .Width = bc
            End With
            With mDayButtons(i).Obj_CmBl
                .Top = mDayButtons(i).Obj_Cmb.Top
                .Left = mDayButtons(i).Obj_Cmb.Left
                .Height = mDayButtons(i).Obj_Cmb.Height
                .Width = mDayButtons(i).Obj_Cmb.Width
            End With
 
            With mDayButtons(i).Obj_CmBlNum
                .Top = Int(i / 7) * lc + _
                       IIf(ShowTitle Or ShowDateSelectors, h_combo, 0) + _
                       IIf(ShowDays, lc, 0) + 6
                .Left = (i Mod 7) * bc + 3
                .Height = Zero_Negative_Value(lc - 6)
                .Width = Zero_Negative_Value(bc - 6)
            End With
 
        Next
 
    Else
        sPHeight = IIf(IsMissing(Height), cDefaultHeight, Height)
        sPWidth = IIf(IsMissing(Width), cDefaultWidth, Width)
    End If
End Sub
 
Public Sub NextDay()
    Dim d As Date
    d = dValue + 1
    d = VBA.DateSerial(CheckYear(VBA.Year(d)), VBA.Month(d), VBA.Day(d))
    Value = d
End Sub
 
Public Sub NextWeek()
    Dim d As Date
    d = dValue + 7
    d = VBA.DateSerial(CheckYear(VBA.Year(d)), VBA.Month(d), VBA.Day(d))
    Value = d
End Sub
 
Public Sub NextMonth()
    Value = SumMonthsToDate(dValue, 1)
End Sub
 
Public Sub NextYear()
    Dim d As Date
    d = VBA.DateSerial(CheckYear(VBA.Year(dValue) + 1), VBA.Month(dValue), VBA.Day(dValue))
    Value = d
End Sub
 
Public Sub PreviousDay()
    Dim d As Date
    d = dValue - 1
    d = VBA.DateSerial(CheckYear(VBA.Year(d)), VBA.Month(d), VBA.Day(d))
    Value = d
End Sub
 
Public Sub PreviousWeek()
    Dim d As Date
    d = dValue - 7
    d = VBA.DateSerial(CheckYear(VBA.Year(d)), VBA.Month(d), VBA.Day(d))
    Value = d
End Sub
 
Public Sub PreviousMonth()
    Value = SumMonthsToDate(dValue, -1)
End Sub
 
Public Sub PreviousYear()
    Dim d As Date
    d = VBA.DateSerial(CheckYear(VBA.Year(dValue) - 1), VBA.Month(dValue), VBA.Day(dValue))
    Value = d
End Sub
 
Public Sub Today()
    Value = VBA.Date
End Sub
 
Public Sub Refresh()
    If bInit Then
        Call Refresh_Panel(VBA.Month(dValue), VBA.Year(dValue))
        Call ApplyFontChanges
    End If
End Sub
 
 
'###########################
'# Events for Main Object Components
'###########################
 
Private Sub CBxY_Change()
    RenderLabel
    Refresh_Panel CBxM.ListIndex + 1, CBxY.ListIndex + 1904
End Sub
 
Private Sub CBxM_Change()
    RenderLabel
    Refresh_Panel CBxM.ListIndex + 1, CBxY.ListIndex + 1904
End Sub
 
Private Sub CmB_Click()
    Main.Obj_ValueSelectionEnabled = bPValueSelectable
    Main.Value = dValue
    If bPValueSelectable Then
        Call Main.Event_click
    End If
End Sub
 
Private Sub CmB_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Call Main.Event_DblClick
End Sub
 
 
Private Sub CmB_KeyDown( _
    ByVal KeyCode As MSForms.ReturnInteger, _
    ByVal Shift As Integer)
 
    Dim newDate As Date
 
    '38 Up
    '37 Left
    '39 Right
    '40 Down
 
    newDate = dValue
 
    Select Case KeyCode
    Case 37
        If bPRightToLeft Then
            newDate = newDate + 1
        Else
            newDate = newDate - 1
        End If
    Case 39
        If bPRightToLeft Then
            newDate = newDate - 1
        Else
            newDate = newDate + 1
        End If
    Case 38
        newDate = newDate - 7
    Case 40
        newDate = newDate + 7
    Case 9
    End Select
 
    If newDate <> dValue Then
        Main.Obj_ValueSelectionEnabled = bPValueSelectable
        Main.Value = newDate
        KeyCode = 0
    Else
        If bPValueSelectable Then
            Call Main.Event_KeyDown(KeyCode, Shift)
        End If
    End If
End Sub
Private Sub Class_Initialize()
    bPShowDays = True
    bPShowTitle = True
    bPShowDateSelectors = True
    dValue = VBA.Date
    lPMonth = VBA.Month(VBA.Date)
    lPYear = VBA.Year(VBA.Date)
    lPDay = VBA.Day(VBA.Date)
    lPFontSize = 8
    lPMonthLength = 0 '1 = mois court, 0 = mois long
    lPDayLength = 1
    bPYearFirst = False
    lPTitleFontColor = &H0& '&HA00000 Couleur du titre Oct 2019
    lPGridFontColor = &HA00000
    lPDayFontColor = &H0& 'Couleur des jours LUN MAR ...
    lPFirstDay = 1
    lPBackColor = &H8000000F 'Couleur de fond des jours damier
    lPHeaderBackColor = &HE0E0E0 'si lPUseDefaultBackColors = False
    lPUseDefaultBackColors = False 'True = Le fond entier du damier de la même couleur : titre + samedi + dimanche
    lPSaturdayBackColor = &HE0E0E0 'si lPUseDefaultBackColors = False
    lPSundayBackColor = &HE0E0E0   'si lPUseDefaultBackColors = False
    lPSelectedBackColor = &HFFFFFF 'couleur du jour sélectionné
    lPUnSelectableBackColor = &H4040C0 '?
    bPVisible = True
    sPHeight = -1
    sPWidth = -1
    sPTop = -1
    sPLeft = -1
    sPControlTipText = "Double clic"
    bPRightToLeft = False
    bPSaturdaySelectable = True
    bPSundaySelectable = True
    bPWeekdaySelectable = True
    bPValueSelectable = True
 
    bPMACFix = False
    If Val(Application.Version) >= 16 Then '"16.0"
        bPMACFix = True 'Office 2016 compatibility :(
    End If
 
    Set TitleFont = New MSForms.NewFont
    With TitleFont
        .Name = "Arial"
        .Size = lPFontSize + 4
        .Bold = True
    End With
 
    Set DayFont = New MSForms.NewFont
    With DayFont
        .Name = "Arial"
        .Size = lPFontSize + 2
        .Bold = True
    End With
 
    Set GridFont = New MSForms.NewFont
    With GridFont
        .Name = "Arial"
        .Size = lPFontSize
    End With
End Sub
Private Sub Class_Terminate()
    Erase mDayButtons
    Erase mLabelButtons
    Set mcMain = Nothing
    Set PTitleNewFont = Nothing
    Set PDayNewFont = Nothing
    Set PGridNewFont = Nothing
    Set CBxY = Nothing
    Set CBxM = Nothing
    Set CmB = Nothing
    Set CLb = Nothing
    Set CmBl = Nothing
End Sub
 
'###########################
'# Private Function
 
Private Function ArraY_Days(ByVal lMonth As Long, ByVal lYear As Long)
    Dim v(0 To 41) As Date, i As Long, g As Long, l As Long, p As Long, t As Date
 
    i = VBA.DateTime.Weekday(VBA.DateSerial(lYear, lMonth, 1), 1 + lPFirstDay Mod 7) - 1
 
    If i = 0 Then i = 7
 
    g = VBA.Day(VBA.DateSerial(lYear, lMonth + 1, 0)) + i
 
    p = 1
    For l = i To 0 Step -1
        v(l) = VBA.DateSerial(lYear, lMonth, p)
        p = p - 1
    Next
 
    p = 0
    For l = i To g
        p = p + 1
        v(l) = VBA.DateSerial(lYear, lMonth, p)
    Next
 
    For l = g To 41
        v(l) = VBA.DateSerial(lYear, lMonth, p)
        p = p + 1
    Next
 
    If bPRightToLeft Then
        For l = 0 To 5
            For i = 0 To 2
                t = v(l * 7 + i)
                v(l * 7 + i) = v(l * 7 + (6 - i))
                v(l * 7 + (6 - i)) = t
            Next
        Next
    End If
 
    ArraY_Days = v
End Function
 
Private Sub RenderLabel()
    Dim b As Currency, b_ym As Currency, b_combo_m As Long
 
    Const b_combo_y As Long = 42
    b_combo_m = IIf(lPMonthLength = mlENShort Or lPMonthLength = mlLocalShort, 42, 66) '66
    b_ym = b_combo_y + 2 + b_combo_m
 
    If bInit Then
        b = CBxY.Parent.Width
        If bPYearFirst Then
            CLb.Caption = CBxY.Value & " " & CBxM.Value
        Else
            CLb.Caption = CBxM.Value & " " & CBxY.Value
        End If
        CLb.Width = Zero_Negative_Value(IIf(ShowDateSelectors, b - b_ym, b))
        CBxM.Width = b_combo_m
        CBxY.Left = IIf(ShowTitle, CLb.Width, CCur((b - b_ym) / 2)) + _
                       IIf(YearFirst, 0, b_combo_m + 2)
        CBxM.Left = IIf(ShowTitle, CLb.Width, CCur((b - b_ym) / 2)) + _
                       IIf(YearFirst, b_combo_y + 2, 0)
        'CBxY.Left = IIf(ShowTitle, CLb.Width, IIf(CLb.Width, Int(CLb.Width / 2), 0)) + _
        '           IIf(YearFirst, 0, b_combo_m + 2)
        '
        'CBxM.Left = IIf(ShowTitle, CLb.Width, IIf(CLb.Width, Int(CLb.Width / 2), 0)) + _
        '           IIf(YearFirst, b_combo_y + 2, 0)
    End If
End Sub
 
Private Function bInit() As Boolean
    bInit = (Not CBxY Is Nothing)
End Function
 
 
Private Function SumMonthsToDate(dDate As Date, Optional lMonth As Long = 1) As Date
    Dim d As Date
 
    d = VBA.DateSerial( _
            VBA.Year(dDate), _
            VBA.Month(dDate) + lMonth, _
            fMin( _
                VBA.Day(dDate), _
                VBA.Day( _
                    VBA.DateSerial( _
                    VBA.Year(dDate), _
                    VBA.Month(dDate) + 1 + VBA.Abs(lMonth), _
                    0))))
 
    If d = VBA.DateSerial(CheckYear(VBA.Year(d)), VBA.Month(d), VBA.Day(d)) Then
        SumMonthsToDate = d
    Else
        SumMonthsToDate = dDate
    End If
End Function
 
Private Function fMin(vFirstValue, ParamArray vValues())
    Dim i As Long
    fMin = vFirstValue
 
    If IsMissing(vValues) = False Then
    For i = 0 To UBound(vValues)
        If fMin > vValues(i) Then
            fMin = vValues(i)
        End If
    Next
    End If
End Function
Private Function fMonthName(lIndex As Long)
    Dim m(11), i As Long, v As Variant
    lIndex = lIndex Mod 4
    If Int(lIndex / 2) Then
        If lIndex Mod 2 Then
            v = Array("Jan", "Feb", "Mar", "Apr", "May", _
                "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
        Else
            v = Array("January", "February", "March", _
                "April", "May", "June", "July", "August", _
                "September", "October", "November", "December")
        End If
        fMonthName = v
    Else
        For i = 0 To 11
            m(i) = VBA.Strings.MonthName(i + 1, lIndex Mod 2)
        Next
        fMonthName = m
    End If
End Function
Private Function fWeekdayName(lIndex As Long)
    Dim m(6), i As Long, v As Variant
    lIndex = lIndex Mod 4
    If Int(lIndex / 2) Then
        If lIndex Mod 2 Then
            v = Array("Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun")
        Else
            v = Array("Monday", "Tuesday", "Wednesday", _
                "Thursday", "Friday", "Saturday", "Sunday")
        End If
        fWeekdayName = v
    Else
        For i = 0 To 6
            m(i) = VBA.Strings.WeekdayName(i + 1, lIndex Mod 2, vbMonday)
        Next
        fWeekdayName = m
    End If
End Function
 
 
Private Function CheckYear(ByVal lYear As Long) As Long
    Select Case lYear
    Case Is < 1904
        CheckYear = 1904
    Case 1904 To 2103
        CheckYear = lYear
    Case Else
        CheckYear = 2103
    End Select
End Function
 
'###########################
'# Private Sub
 
Public Sub Event_DblClick()
    RaiseEvent DblClick
End Sub
 
Public Sub Event_click()
    RaiseEvent Click
End Sub
 
Public Sub Event_KeyDown( _
    ByVal KeyCode As MSForms.ReturnInteger, _
    ByVal Shift As Integer)
 
    RaiseEvent KeyDown(KeyCode, Shift)
End Sub
Private Sub Refresh_Properities()
    With Me
        .BackColor = .BackColor
        .ControlTipText = .ControlTipText
        .DayFontColor = .DayFontColor
        .DayLength = .DayLength
        .GridFontColor = .GridFontColor
        .MonthLength = .MonthLength
        If .UseDefaultBackColors = False Then
            .SaturdayBackColor = .SaturdayBackColor
            .SundayBackColor = .SundayBackColor
            .HeaderBackColor = .HeaderBackColor
        End If
        .ShowDateSelectors = .ShowDateSelectors
        .ShowDays = .ShowDays
        .ShowTitle = .ShowTitle
        .TabIndex = .TabIndex
        .TabStop = .TabStop
        .TitleFontColor = .TitleFontColor
        .ValueIsNull = .ValueIsNull
        .YearFirst = .YearFirst
    End With
End Sub
 
Private Sub Refresh_Selected_Day(ByVal dValue As Date, ByVal i As Long)
    Dim c As MSForms.Label
    Dim selColor As OLE_COLOR
 
    If Not bPValueIsNull Then
        bPValueSelectable = mDayButtons(i).Obj_ValueSelectionEnabled
        If bPValueSelectable Then
            selColor = lPSelectedBackColor
        Else
            selColor = lPUnSelectableBackColor
        End If
        On Error Resume Next
        mDayButtons(i).Obj_Cmb.SetFocus
        On Error GoTo 0
        If Not bPMACFix Then
            With mDayButtons(i).Obj_CmBl
                .BackStyle = fmBackStyleOpaque
                .BackColor = selColor
                .ForeColor = cDayFontColorSelected
            End With
        Else
            With mDayButtons(i).Obj_Cmb
                .BackStyle = fmBackStyleOpaque
                .BackColor = selColor
                .ForeColor = cDayFontColorSelected
            End With
        End If
        lPMonth = VBA.Month(dValue)
        lPYear = VBA.Year(dValue)
        lPDay = VBA.Day(dValue)
    End If
 
End Sub
 
Private Sub Refresh_Panel(ByVal lMonth As Long, ByVal lYear As Long)
    Dim v As Variant, i As Long, l As Long, idxSel As Variant
    Dim iDay As Long
    Dim lBackColor As OLE_COLOR
    Dim lBackColorA As Variant
    Dim colorArray42() As Variant
    Dim selArray42() As Variant
    Dim bHasColoredDateArray As Boolean
    Dim bSelectable As Boolean
 
    If Not bInit Then
        Exit Sub
    End If
 
    bHasColoredDateArray = HasColoredDateArray()
 
    v = ArraY_Days(lMonth, lYear)
 
    If bHasColoredDateArray Then
        ReDim colorArray42(0 To 41)
        ReDim selArray42(0 To 41)
 
        Call BuildDateColorArrays(colorArray42, selArray42, v(0), v(41))
    End If
 
    idxSel = Empty
    For i = 0 To 41
        mDayButtons(i).Value = v(i)
        If v(i) = dValue Then
            idxSel = i
        End If
        If Not bPMACFix Then 'MAC: no label - command button text
            '# Normal mode
            ' Text day label
            With mDayButtons(i).Obj_CmBlNum
                If .Caption <> VBA.Day(v(i)) Then
                    .Caption = VBA.Day(v(i))
                End If
                If lMonth = VBA.Month(v(i)) Then
                    If .ForeColor <> GridFontColor Then
                        .ForeColor = GridFontColor
                    End If
                Else
                    If .ForeColor <> cDayFontColorInactive Then
                        .ForeColor = cDayFontColorInactive
                    End If
                End If
            End With
            ' Day background label
            With mDayButtons(i).Obj_CmBl
                iDay = VBA.DateTime.Weekday(v(i))
                If .BackStyle = fmBackStyleOpaque Then
                    .BackStyle = fmBackStyleTransparent
                End If
                lBackColor = lPBackColor
                If UseDefaultBackColors = False Then
                    If iDay = vbSaturday Then
                        lBackColor = lPSaturdayBackColor
                        If .BackStyle <> fmBackStyleOpaque Then
                            .BackStyle = fmBackStyleOpaque
                        End If
                    ElseIf iDay = vbSunday Then
                        lBackColor = lPSundayBackColor
                        If .BackStyle <> fmBackStyleOpaque Then
                            .BackStyle = fmBackStyleOpaque
                        End If
                    End If
                    If bHasColoredDateArray Then
                        lBackColorA = colorArray42(i)
                        If Not IsEmpty(lBackColorA) Then
                            lBackColor = lBackColorA
                            If .BackStyle <> fmBackStyleOpaque Then
                                .BackStyle = fmBackStyleOpaque
                            End If
                        End If
                    End If
                End If
                If .BackColor <> lBackColor Then
                    .BackColor = lBackColor
                End If
            End With
            ' Button not altered
            With mDayButtons(i).Obj_Cmb
                If .Caption <> "" Then 'After MACFix
                    .Caption = ""
                End If
                If .BackStyle <> fmBackStyleTransparent Then 'Button visible
                    .BackStyle = fmBackStyleTransparent
                End If
            End With
        Else
            '# MAC Fix mode
            With mDayButtons(i).Obj_CmBlNum
                If .Caption <> "" Then
                    .Caption = ""
                End If
            End With
            With mDayButtons(i).Obj_CmBl
                If .BackStyle = fmBackStyleOpaque Then
                    .BackStyle = fmBackStyleTransparent
                End If
            End With
            With mDayButtons(i).Obj_Cmb
                If .Caption <> VBA.Day(v(i)) Then
                    .Caption = VBA.Day(v(i))
                End If
                If lMonth = VBA.Month(v(i)) Then
                    If .ForeColor <> GridFontColor Then
                        .ForeColor = GridFontColor
                    End If
                Else
                    If .ForeColor <> cDayFontColorInactive Then
                        .ForeColor = cDayFontColorInactive
                    End If
                End If
                If .BackStyle <> fmBackStyleOpaque Then 'Button visible
                    .BackStyle = fmBackStyleOpaque
                End If
                lBackColor = lPBackColor
                If UseDefaultBackColors = False Then
                    iDay = VBA.DateTime.Weekday(v(i))
                    If iDay = vbSaturday Then
                        lBackColor = lPSaturdayBackColor
                    ElseIf iDay = vbSunday Then
                        lBackColor = lPSundayBackColor
                    End If
                    If bHasColoredDateArray Then
                        lBackColorA = colorArray42(i)
                        If Not IsEmpty(lBackColorA) Then
                            lBackColor = lBackColorA
                        End If
                    End If
                End If
                If .BackColor <> lBackColor Then
                    .BackColor = lBackColor
                End If
            End With
        End If
 
        If Not SaturdaySelectable And iDay = vbSaturday Then
            bSelectable = False
        ElseIf Not SundaySelectable And iDay = vbSunday Then
            bSelectable = False
        ElseIf Not WeekdaySelectable And iDay <> vbSaturday And iDay <> vbSunday Then
            bSelectable = False
        Else
            bSelectable = True
        End If
        If bHasColoredDateArray Then
            If Not IsEmpty(selArray42(i)) Then
                bSelectable = selArray42(i)
            End If
        End If
        mDayButtons(i).Obj_ValueSelectionEnabled = bSelectable
 
        If CheckValue(v(i)) = False Then
            mDayButtons(i).Obj_Cmb.Locked = True
        Else
            If mDayButtons(i).Obj_Cmb.Locked = True Then
                mDayButtons(i).Obj_Cmb.Locked = False
            End If
        End If
    Next
 
    If UseDefaultBackColors = False Then
        For l = 0 To 6
            If mLabelButtons(l).Obj_CmBl.BackStyle = fmBackStyleTransparent Then
                mLabelButtons(l).Obj_CmBl.BackStyle = fmBackStyleOpaque
            End If
            If mLabelButtons(l).Obj_CmBl.BackColor <> lPHeaderBackColor Then
                mLabelButtons(l).Obj_CmBl.BackColor = lPHeaderBackColor
            End If
        Next
    Else
        For l = 0 To 6
            If mLabelButtons(l).Obj_CmBl.BackStyle = fmBackStyleOpaque Then
               mLabelButtons(l).Obj_CmBl.BackStyle = fmBackStyleTransparent
            End If
        Next
    End If
 
    If lMonth = VBA.Month(dValue) And lYear = VBA.Year(dValue) Then
        Call Refresh_Selected_Day(dValue, idxSel)
    Else
        lPMonth = 0
        lPYear = 0
        lPDay = 0
    End If
End Sub
 
Private Function CheckValue(d) As Boolean
    If VarType(d) = vbDate Then
        Select Case d
            Case 1462 To 74510
                CheckValue = CLng(d) = d
        End Select
    End If
End Function
 
Private Function Zero_Negative_Value(sNumber As Single) As Single
    If sNumber > 0 Then
        Zero_Negative_Value = sNumber
    End If
End Function
 
'##########################################################
'# Coloring Date Arrays
 
Public Function HasColoredDateArray() As Boolean
    HasColoredDateArray = Not IsEmpty(maColoredArrayTable)
End Function
 
Public Function AddColoredDateArray(color As OLE_COLOR, dates As Variant, Optional Selectable As Variant = Empty, Optional index As Long = -1) As Long
    Dim r As Object 'Excel.Range
    Dim dateList() As Variant
    Dim aColoredArrayTable() As Variant
    Dim aColoredArrayRec() As Variant
    Dim newIndex As Long
    Dim lUBnd As Long
    Dim dat As Variant
    Dim format As Integer '1 - 1 dimension, 2 - 1/2 dimension, 3 - 2/2 dimension
 
    If TypeName(dates) = "Variant()" Then
        dateList = dates
    ElseIf TypeName(dates) = "Range" Then
        Set r = dates
        dateList = r.Value2
    Else
        Err.Raise 20001, "Invalid input type for dates: " & TypeName(dates) & " (Valid: Range, Variant())"
    End If
 
    If Not IsEmpty(Selectable) Then
        Selectable = CBool(Selectable)
    End If
 
    newIndex = index
    If IsEmpty(maColoredArrayTable) Then
        If newIndex = -1 Then
            newIndex = 1
        End If
        ReDim aColoredArrayTable(1 To newIndex)
    Else
        aColoredArrayTable = maColoredArrayTable
        If newIndex = -1 Then
            newIndex = UBound(aColoredArrayTable) + 1
        End If
        If newIndex > UBound(aColoredArrayTable) Then
            ReDim Preserve aColoredArrayTable(1 To newIndex)
        End If
    End If
 
    format = 1
    On Error Resume Next
    lUBnd = UBound(dateList)
    dat = dateList(lUBnd)
    If Err.Number > 0 Then
        Err.Clear
        lUBnd = UBound(dateList, 1)
        dat = dateList(lUBnd, 1)
        If Err.Number > 0 Then
            Err.Raise 20001, "Invalid date array input: " & Err.Description
        End If
 
        format = 2
        If lUBnd < UBound(dateList, 2) Then
            format = 3
        End If
    End If
    On Error GoTo 0
 
    ReDim aColoredArrayRec(1 To 4)
    aColoredArrayRec(ccColor) = color
    aColoredArrayRec(ccFormat) = format
    aColoredArrayRec(ccDateList) = dateList
    aColoredArrayRec(ccSelectable) = Selectable
 
    aColoredArrayTable(newIndex) = aColoredArrayRec
 
    maColoredArrayTable = aColoredArrayTable
 
    Call Refresh
 
    AddColoredDateArray = newIndex
End Function
 
Public Sub RemoveColoredDateArray(index As Long)
    Dim aColoredArrayTable() As Variant
    Dim i As Long
    Dim bWas As Boolean
    If HasColoredDateArray() Then
        aColoredArrayTable = maColoredArrayTable
        If 1 <= index And index <= UBound(aColoredArrayTable) Then
            aColoredArrayTable(index) = Empty
            bWas = False
            For i = 1 To UBound(aColoredArrayTable)
                If Not IsEmpty(aColoredArrayTable(i)) Then
                   bWas = True
                   Exit For
                End If
            Next
            If bWas Then
                maColoredArrayTable = aColoredArrayTable
            Else
                maColoredArrayTable = Empty
            End If
        End If
    End If
End Sub
 
Public Sub ClearAllColoredDateArrays()
    maColoredArrayTable = Empty
End Sub
 
 
Public Function IsColoredArrayExists(index As Long) As Boolean
    Dim aColoredArrayRec() As Variant
    Call GetColoredArrayRec(index, aColoredArrayRec)
    IsColoredArrayExists = Not IsEmpty(aColoredArrayRec)
End Function
 
Public Function GetArrayColor(index As Long) As Variant
    Dim aColoredArrayRec() As Variant
    Call GetColoredArrayRec(index, aColoredArrayRec)
    If Not IsEmpty(aColoredArrayRec) Then
        GetArrayColor = aColoredArrayRec(ccColor)
        Exit Function
    End If
    GetArrayColor = Empty
End Function
 
Public Sub SetArrayColor(index As Long, color As OLE_COLOR)
    Dim aColoredArrayRec() As Variant
    Call GetColoredArrayRec(index, aColoredArrayRec)
    If Not IsEmpty(aColoredArrayRec) Then
        aColoredArrayRec(ccColor) = color
        Call SetColoredArrayRec(index, aColoredArrayRec)
    End If
End Sub
 
Public Function GetArraySelectable(index As Long) As Variant
    Dim aColoredArrayRec() As Variant
    Call GetColoredArrayRec(index, aColoredArrayRec)
    If Not IsEmpty(aColoredArrayRec) Then
        GetArraySelectable = aColoredArrayRec(ccSelectable)
        Exit Function
    End If
    GetArraySelectable = Empty
End Function
 
Public Sub SetArraySelectable(index As Long, Selectable As Variant)
    Dim aColoredArrayRec() As Variant
    If Not IsEmpty(Selectable) Then
        Selectable = CBool(Selectable)
    End If
    Call GetColoredArrayRec(index, aColoredArrayRec)
    If Not IsEmpty(aColoredArrayRec) Then
        aColoredArrayRec(ccSelectable) = Selectable
        Call SetColoredArrayRec(index, aColoredArrayRec)
    End If
End Sub
 
Private Sub GetColoredArrayRec(index As Long, ByRef aColoredArrayRec() As Variant)
    Dim aColoredArrayTable() As Variant
    If HasColoredDateArray() Then
        aColoredArrayTable = maColoredArrayTable
        If 1 <= index And index <= UBound(aColoredArrayTable) Then
            If Not IsEmpty(aColoredArrayTable(index)) Then
                aColoredArrayRec = aColoredArrayTable(index)
                Exit Sub
            End If
        End If
    End If
    aColoredArrayRec = Empty
End Sub
 
Private Sub SetColoredArrayRec(index As Long, ByRef aColoredArrayRec() As Variant)
    Dim aColoredArrayTable() As Variant
    If HasColoredDateArray() Then
        aColoredArrayTable = maColoredArrayTable
        If 1 <= index And index <= UBound(aColoredArrayTable) Then
            aColoredArrayTable(index) = aColoredArrayRec
            maColoredArrayTable = aColoredArrayTable
        End If
    End If
End Sub
 
 
Private Sub BuildDateColorArrays(ByRef colorArray42() As Variant, ByRef selArray42() As Variant, ByVal fromDate As Date, ByVal toDate As Date)
    Dim aColoredArrayTable() As Variant
    Dim aColoredArrayRec() As Variant
    Dim iDate As Date
    Dim format As Integer '1 - 1 dimension, 2 - 2 dimension/1, 2 - 2 dimension/2
    Dim dateList() As Variant
    Dim i As Long
    Dim j As Long
    Dim idx As Integer
 
    If Not HasColoredDateArray() Then
        Exit Sub
    End If
 
    aColoredArrayTable = maColoredArrayTable
 
    For i = 1 To UBound(aColoredArrayTable)
        aColoredArrayRec = aColoredArrayTable(i)
 
        format = aColoredArrayRec(ccFormat)
        dateList = aColoredArrayRec(ccDateList)
 
        Select Case format
        Case 1
            For j = LBound(dateList) To UBound(dateList)
                iDate = dateList(j)
                If fromDate <= iDate And iDate <= toDate Then
                    idx = iDate - fromDate
                    colorArray42(idx) = aColoredArrayRec(ccColor)
                    selArray42(idx) = aColoredArrayRec(ccSelectable)
                End If
            Next
        Case 2
            For j = LBound(dateList, 1) To UBound(dateList, 1)
                iDate = dateList(j, 1)
                If fromDate <= iDate And iDate <= toDate Then
                    idx = iDate - fromDate
                    colorArray42(idx) = aColoredArrayRec(ccColor)
                    selArray42(idx) = aColoredArrayRec(ccSelectable)
                End If
            Next
        Case 3
            For j = LBound(dateList, 2) To UBound(dateList, 2)
                iDate = dateList(1, j)
                If fromDate <= iDate And iDate <= toDate Then
                    idx = iDate - fromDate
                    colorArray42(idx) = aColoredArrayRec(ccColor)
                    selArray42(idx) = aColoredArrayRec(ccSelectable)
                End If
            Next
        End Select
    Next
 
End Sub

[deedolith]

Salut,

A partir du moment où tu as une date, calculer la N° de semaine est trivial:

Code :

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

1
2
3
Public Function getWeekNumber(ByVal Dt As Date) As Byte
    getWeekNumber = Application.WorksheetFunction.WeekNum(Dt)
End Function

Par contre, sans le source complet, il n'y a rien que l'on puisse faire.

PS: Une gigantesque classe de plus de 1800 lignes, et plus de 50 variables, je ne voit pas comment ca peut être bon ...

[Invité]

Bonjour goninph

Effectivement, cette classe est plutôt bien foutue on a juste besoin d'un USF avec un label nommé "Label_Today" et d'un frame

A+

[goninph]

Merci BrunoM45

Je n'ai pas compris le fonctionnement des jours fériés, n'ai besoin que des jours fériés suisses

Autre amélioration que l'on pourrait apporter à ce super calendrier :
- Fermeture du calendrier par la touche escape du clavier
- La date remontée dans le calendrier n'est pas colorée dans le calendrier
- Le label aujourd'hui devrait être un bouton pour régénérer le calendrier sur le mois en cours lorsque l'on clique dessus
- Les boutons vides du mois précédant et suivant devrait indiquer les numéros des jours
- Simple clic sur les jours du mois précédent pour afficher le mois précédent et inversement pour le mois suivant
- Double-clique pour lâcher la date

Déclencher le calendrier avec la mise en forme de la cellule

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
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim DateFormats, DF 'Afficher le calendrier selon le format de la cellule
Application.ScreenUpdating = False
    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
            Select Case Target.Column
                Case Else: Target = Calendar.ShowX(Target(1), 2, 0, 13):    ' region = 13  "suisse"
            End Select
        End If
    Next
Application.ScreenUpdating = True
End Sub

La ligne plante lorsque l'on utilise la touche escape

Code :

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

Private Sub Cbyear_Change(): SpinButton2.Value = Cbyear.Value: Calendar.ReloadClavier: End Sub

À remplacer par :

Code :

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

1
2
3
4
5
6
Private Sub Cbyear_Change()
    If Cbyear.Value <> "" Then
        SpinButton2.Value = Cbyear.Value
        USF_Calendar.ReloadClavier
    End If
End Sub

Problème avec cette modification, la date de la cellule est effacée

[goninph]

Je ne comprends pas le fonctionnement de ce code

Qui peut m'éclairer ?

Merci

Code :

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

1
2
3
            Select Case Target.Column
                Case Else: Target = Calendar.ShowX(Target(1), 2, 0, 13):    ' region = 13  "suisse"
            End Select

[Invité]

Bonjour,

Vous ne donnez pas le code entier, comment voulez-vous qu'un forumeur lambda le comprenne

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
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)    If Target.Count > 1 Then Exit Sub
    If Target(1).Row = 1 Or Target.Columns.Count > 1 Then Exit Sub
    Cancel = True
 
 
    Select Case Target.Column
 
 
    Case 1: Target = Calendar.ShowX(Target(1), 2, 0, 0):    ' region = 0 ou "US" Etats Unis
 
 
    Case 2: Target = Calendar.ShowX(Target(1), 2, 0, 1):    ' region = 1 ou "FR" France
 
 
    Case 3: Target = Calendar.ShowX(Target(1), 2, 0, 2):    ' region = 2  ou "CA" Canada
 
 
    Case 4: Target = Calendar.ShowX(Target(1), 2, 0, 22):    ' region = 22  "QUEBEC" Canada
 
 
    Case 5: Target = Calendar.ShowX(Target(1), 2, 0, 12):    ' region = 12  "iTALY"
 
 
    Case 6: Target = Calendar.ShowX(Target(1), 2, 0, 13):    ' region = 13  "suisse"
 
 
    Case 7: Target = Calendar.ShowX(Target(1), 2, 0, 33):    ' region = 33  "Grande bretagne"
 
 
    Case Else: Target = Calendar.ShowX(Target(1), 0, 2):    'automatique region
 
 
    End Select
 
 
    'Unload Calendar
End Sub

Voici l'explication
https://learn.microsoft.com/fr-fr/of...ase-statements

[goninph]

Bonjour c'est le code de la feuille du fichier que vous m'avez conseillé
Je tiens à vous remerciez pour ce lien
Le calendrier et top
J'essaye de l'adapter pour pouvoir remplacer tous les calendriers de tout mes fichiers

[goninph]

J'aimerai supprimer le target par Activecell.Value
Vous m'avez déjà bien aidé, je vais me remettre dessus en fin de journée

[Invité]

Re,

Ce qu'il faudrait que l'on sache c'est dans quel évènement ou procédure vous lancez l'USF !?

A+

[deedolith]

Pour les jours fériés, il y a 2 cas:
- Les jours fériés fixe (par exemple, le 14 Juillet, fête nationale en france).
- Les jours fériés basés sur la date de Pâque. Tous les pays ne fêtant ces derniers (en totalité ou en partie), le mieux est de consulter ce lien.

[goninph]

Re,

Ce qu'il faudrait que l'on sache c'est dans quel évènement ou procédure vous lancez l'USF !?

A+

Par exemple dans la feuille

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
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim DateFormats, DF 'Afficher le calendrier selon le format de la cellule
Application.ScreenUpdating = False
    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
            Select Case Target.Column
                Case Else: Target = Calendar.ShowX(Target(1), 2, 0, 13):    ' region = 13  "suisse"
            End Select
        End If
    Next
Application.ScreenUpdating = True
End Sub

[deedolith]

Salut,

Même si c'est possible, les paramètre passés par valeurs (mot clef: ByVal) n'on pas vocation à être modifiés.
Le mieux et d'instancier un nouvel objet Range:

Code :

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

1
2
Dim Rng As Excel.Range
Set Rng = Target

[Invité]

Bonjour le fil,

Par exemple dans la feuille

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
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim DateFormats, DF 'Afficher le calendrier selon le format de la cellule
Application.ScreenUpdating = False
    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
            Select Case Target.Column
                Case Else: Target = Calendar.ShowX(Target(1), 2, 0, 13):    ' region = 13  "suisse"
            End Select
        End If
    Next
Application.ScreenUpdating = True
End Sub

Pourquoi vouloir, je site

J'aimerai supprimer le target par Activecell.Value

Alors que "Target" représente justement "Activecell", pas vraiment compris 🤔

Sinon @deedolith vous a apporté un élément de réponse

A+

[goninph]

Bonjour le fil,


Pourquoi vouloir, je site
Alors que "Target" représente justement "Activecell", pas vraiment compris 🤔

Sinon @deedolith vous a apporté un élément de réponse

A+

Parce que j'aimerais pouvoir l'utiliser pour renseigner la Textbox d'un Userform par exemple : Target = Me.Textbox.value

et je n'ai pas encore compris ce code, à quoi correspondent les numéros, mais je cherche

Code :

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

Target = Calendar.ShowX(Target(1), 2, 0, 13):

[Philippe Tulliez]

Bonjour,

et je n'ai pas encore compris ce code, à quoi correspondent les numéros, mais je chercheTarget = Calendar.ShowX(Target(1), 2, 0, 13):

C'est pourtant expliqué dans son code
Le premier argument c'est l'objet où doit être renvoyé la date sélectionnée, le 2ème argument c'est la position gauche du Calendrier par rapport à l'objet (argument 1), le 3ème est la position par rapport à la hauteur et le 4ème c'est le pays (pour la suisse c'est 13). Tout est commenté dans les codes

'definition de l'apel pour ((ShowX ))
'ShowX( [CIBLE] , [COTE DE LA CIBLE(0,1,2)] , [TOP DE LA CIBLE(0,1,2)] , [REGION(0,1,2)] )
'Exemple:
'dans un module : With Cells(15, 2): .Value = Calendar.ShowX(.Cells(1), 2, 0, 1): End With
'dans un evenement worksheet: Target = Calendar.ShowX(Target(1), 2, 0, 0):
'dans un evenement control ActivX : TextBox1 = Calendar.ShowX(TextBox1, 2, 0, 0)

Target(1) est la partie supérieure gauche de Target (intéressant si Target est une plage de cellules) mais dans une procédure événementielle qui intercepte le double clic on ne peut sélectionner plusieurs cellules sauf si elle est fusionnée d'où Target(1)

Il suffit d'effectuer un test à partir d'une cellule d'une nouvelle feuille et modifier les paramètres pour comprendre son fonctionnement

Parce que j'aimerais pouvoir l'utiliser pour renseigner la Textbox d'un Userform par exemple : Target = Me.Textbox.value

Dans le classeur que vous avez téléchargé, il y a un autre UserForm nommé testeur avec plusieurs exemples de l'utilisation du calendrier avec un TextBox

[goninph]

Merci pour toutes ces explications

Ce que j'aimerais réaliser, c'est simplifier au maximum la macro seulement pour la suisse

Voici ce que j'ai déjà modifié dans le code et dans le design

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
Option Explicit
'******************************************************************************************************************
'definition de l'apel pour ((ShowX ))
'ShowX(  [CIBLE]  ,  [COTE DE LA CIBLE(0,1,2)]  ,  [TOP DE LA CIBLE(0,1,2)]   , [REGION(0,1,2)]  )
'Exemple:
'dans un module :                        With Cells(15, 2): .Value = Calendar.ShowX(.Cells(1), 2, 0, 1): End With
'dans un evenement worksheet:            Target = Calendar.ShowX(Target(1), 2, 0, 0):
'dans un evenement control ActivX :      TextBox1 = Calendar.ShowX(TextBox1, 2, 0, 0)
'******************************************************************************************************************
'definition de l'apel pour ((ShowTopLeft ))
'ShowTopLeft(    [left du calendrier]  ,  [TOP du calendrier]   , [REGION(0,1,2)]  )
'Exemple:
'dans un module :         MsgBox Calendar.ShowTopLeft(155, 230, 2)
'******************************************************************************************************************
'PAR PRINCIPE LA FONCTION D'APPEL SE CHARGE DE TOUT ETANT DONNE QU'ELLE A UN COMPORTEMENT
'COMPLETEMENT INDEPENDANT DU MODULE USERFORM COMME SI ELLE ETAIT DANS UN AUTRE MODULE
'
'                        ABSOLUMENT  TOUT LE CALENDRIER REPOSE SUR CE PRINCIPE!!!
'******************************************************************************************************************
Dim bt1Back As Variant
Dim btweekfc As Variant
Dim btweekBack As Variant
Dim bt1fc As Variant
Dim mobildayback As Variant
Dim mobildayFC As Variant
Dim bt2Back As Variant
Dim backfériéday As Variant
Dim fériédayFC As Variant
Public region
Public Obj As Object
Public oldvalue
Public WithEvents Bout As MSForms.Label    'map pour 42 bouton
Public lance As Boolean
Public jour
Public mois
Public an
Public valeur As Date
Private clavier(43) As New Calendar    'tableau d'instance de l'userform
'Fonction appelée par un range ou msforms.control ET REGION
Public Function ShowX(Optional objX As Object, Optional Side As Long = 2, Optional top As Long = 0, Optional optionRegionale As Long = 1000)
Dim T#
Dim Forme
bt1Back = &HE0E0E0      'Couleur Background bouton jour
bt1fc = &H0&            'Couleur texte bouton jour
btweekBack = &H80000004 'Couleur Background bouton jour weekend
btweekfc = &H0&         'Couleur texte bouton jour weekend
mobildayback = &HC0FFFF 'Couleur Background bouton jour mobile
mobildayFC = &H0&       'Couleur texte jour mobile
bt2Back = &H80000004    'Couleur Background boutons jour vide
backfériéday = &HC0C0FF 'Couleur Background boutons jour férié
fériédayFC = &H0&       'Couleur texte bouton jour férié
    region = 13 'optionRegionale
    Set Obj = objX    'les variables argument doivent etre instruites  avant le show IMPORTANT!!!!!!!!!!
    lance = True
    If TypeName(Obj) = "Range" Then placementRange Obj Else placementUF Obj
    Me.startupposition = 0: Me.Show
    If TypeName(Obj) = "Range" Then
        valeur = DateSerial(an, mois, jour)
    Else
        valeur = format(DateSerial(an, mois, jour), Forme)
    End If
        ShowX = valeur    'on modifie  valeur apres le show
    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
    config
    If Not Obj Is Nothing Then
        Select Case TypeName(Obj)
        Case "Label": oldvalue = Obj.Caption
        Case "TextBox": oldvalue = Obj.Value
        Case "CommandButton": oldvalue = Obj.Caption
        End Select
    End If
    TRT = "Calendrier - Suisse": ldate = "Aujourd'hui " & format(Date, "dddd dd.mm.yyyy")
    Me.Caption = TRT
    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
'evenement unique pour 42 boutons
Private Sub bout_Click()
    With Calendar: .jour = Bout.Caption: .mois = .Cbmonth.ListIndex + 1: .an = .Cbyear.Value: .Hide: End With    'le unload se fait ailleurs
End Sub
Private Sub ldate_Click()
    config_BT_Today
End Sub
Sub config_BT_Today()
    Dim Listdays, dat, I&
    If Calendar.region = 1000 Then Calendar.region = Application.International(xlDateOrder)    'AUTOMATIQUE SYSTEM
    Calendar.Cbmonth.List = Split("Janvier, Février, Mars, Avril, Mai, Juin, Juillet, Août, Septembre, Octobre, Novembre, Décembre", ",")
    Listdays = Split("Lun,Mar,Mer,Jeu,Vend,Sam,Dim,Sem", ",")
    dat = Date
    Calendar.Cbmonth.ListIndex = Month(dat) - 1
    For I = 1900 To Year(dat) + 100: Calendar.Cbyear.AddItem I: Next
    For I = 0 To 6: With Calendar.Controls("d" & I + 1): .Caption = Listdays(I): End With: Next
    Calendar.sem0.Caption = Listdays(7)
    SpinButton1.Value = Month(dat): SpinButton2.Value = Year(dat)
    ReloadClavier
    Me.Repaint
End Sub
Sub config()
    Dim Listdays, dat, I&
    If Calendar.region = 1000 Then Calendar.region = Application.International(xlDateOrder)    'AUTOMATIQUE SYSTEM
    Calendar.Cbmonth.List = Split("Janvier, Février, Mars, Avril, Mai, Juin, Juillet, Août, Septembre, Octobre, Novembre, Décembre", ",")
    Listdays = Split("Lun,Mar,Mer,Jeu,Vend,Sam,Dim,Sem", ",")
    If Not Obj Is Nothing Then 'Remonte la date existante dans le calendrier
        If IsDate(Obj) Then
            dat = IIf(Calendar.region = 0 And TypeName(Obj) <> "Range", format(Obj.Value, "mm/dd/yyyy"), CDate(Obj.Value))
        Else
            dat = Date    ': If Not Obj Is Nothing And IsDate(Obj) Then dat = IIf(Calendar.region = 0 And TypeName(Obj) <> "Range", Format(Obj.Value, "mm/dd/yyyy"), Obj.Value)
        End If
    End If
    Calendar.Cbmonth.ListIndex = Month(dat) - 1
    For I = 1900 To Year(dat) + 100: Calendar.Cbyear.AddItem I: Next
    For I = 0 To 6: With Calendar.Controls("d" & I + 1): .Caption = Listdays(I): End With: Next
    Calendar.sem0.Caption = Listdays(7)
    SpinButton1.Value = Month(dat): SpinButton2.Value = Year(dat)
    ReloadClavier
    Me.Repaint
End Sub
'evenement combo et spinbutton(month/year)
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
Private Sub SpinButton2_Change(): Cbyear.Value = SpinButton2.Value: End Sub
 
Private Sub Cbmonth_Change(): SpinButton1.Value = Cbmonth.ListIndex + 1: Calendar.ReloadClavier: End Sub
Private Sub Cbyear_Change(): SpinButton2.Value = Cbyear.Value: Calendar.ReloadClavier: 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 Calendar.region
    Case 0, 22: WkD = vbSunday
    Case 1, 2, 12, 13: WkD = vbMonday
    End Select
    X = Weekday(DateSerial(Calendar.Cbyear, Calendar.Cbmonth.ListIndex + 1, 1), WkD)
    NB_JOURS = Day(DateSerial(Cbyear.Value, Cbmonth.ListIndex + 2, 0))
    For I = 1 To 6: Me.Controls("sem" & I) = "": Next
    For I = 1 To 42
        With Calendar.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(Calendar.Cbyear.Value, Calendar.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 Sub placementUF(Obj As Object)
    If Not Obj Is Nothing Then
        Dim Lft As Double, Rgt As Double, top As Double, Bot As Double, P As Object, PInsWidth As Double, PInsHeight As Double
        Dim K As Double, Zom As Double, Ombre As Double, EcX As Double, OpWin As Long
        OpWin = Int(Val(Mid(Application.OperatingSystem, InStrRev(Application.OperatingSystem, " ") + 1)))    'number version system
        If OpWin = 6 Or Int(Val(Application.Version)) < 15 Then EcX = 2: Ombre = 2 Else EcX = 0: Ombre = 0     'ecart cadre
        Lft = Obj.Left: top = Obj.top: Set P = Obj.Parent    ' Normalement Page, Frame ou UserForm
        Do
            PInsWidth = P.InsideWidth: PInsHeight = P.InsideHeight    ' Le Page en est pourvu, mais pas le Multipage.
            If TypeOf P Is MSForms.Page Then Set P = P.Parent    ' Prend le Multipage, car le Page est sans positionnement.
            K = (P.Width - PInsWidth) / 2: Lft = (Lft + P.Left + K): top = (top + P.top + P.Height - K - PInsHeight)
            If Not (TypeOf P Is MSForms.Frame Or TypeOf P Is MSForms.MultiPage) Then Exit Do
            Set P = P.Parent
        Loop
        Me.Left = Lft + EcX + Ombre + ((Obj.Width / 2) * Px)    ' a gauche en top
        Me.top = top + 2 + Ombre + ((Obj.Height / 2) * Py)
    End If
End Sub
Private Function placementRange(Obj As Object)
    If Obj Is Nothing Then Exit Function
    Dim z#, EcX#, L1#, T1#, C#, R#, Vr As Range, Hx#, Wx#, Ok As Boolean, Op&, PtoPx#, I&
    With ActiveWindow
        PtoPx = (.ActivePane.PointsToScreenPixelsX(72) - .ActivePane.PointsToScreenPixelsX(0)) / 72    'coeff point to pixel
        Op = Int(Val(Mid(Application.OperatingSystem, InStrRev(Application.OperatingSystem, " ") + 1)))    'number version system
        'exit si la cellule injecté n'est pas vible a l'ecran
        For I = 1 To .Panes.Count: Ok = IIf(Not Intersect(.Panes(I).VisibleRange, Obj) Is Nothing, True, Ok): Next
        If Ok = False Then Beep: MsgBox " cette cellule n'est pas visible a l'ecran": Exit Function
        z = (ActiveWindow.Zoom / 100): Set Vr = .VisibleRange    'Coeff zoom ,  rangevisible partie mobile
        EcX = 4 And Op = 6 And Int(Val(Application.Version)) < 16  'ecart cadre
        L1 = (.ActivePane.PointsToScreenPixelsX(Int(Obj.Left)) / PtoPx) * z + EcX    'placement partie mobile
        T1 = .ActivePane.PointsToScreenPixelsY(Int(Obj.top)) / PtoPx * z + EcX
        With .Panes(1).VisibleRange: C = .Cells(.Cells.Count).Column: R = .Cells(.Cells.Count).Row: End With    'limite splitrow et splitcolumn
        If .SplitRow > 0 Then  'placement  dans le splitrow
            If Obj.Row < R + 1 And .ScrollRow > R Then T1 = ((.ActivePane.PointsToScreenPixelsY(Vr.Cells(1).top) / PtoPx) * z) - (Range(Obj, Cells(R, 1)).Height * z) + EcX
        End If
        If .SplitColumn > 0 Then    'placement  dans le splitcolumn
            If Obj.Column < C + 1 And .ScrollColumn > C Then L1 = ((.ActivePane.PointsToScreenPixelsX(Vr.Cells(1).Left) / PtoPx) * z) - (Range(Obj, Cells(1, C)).Width * z) + EcX
        End If
    End With
    'Option de placement
    Me.Left = Application.Left + Application.Width / 2 - Me.Width / 2 'Pour centrer sur l'application Application.Left + Application.Width / 2 - Me.Width / 2
    Me.top = Application.top + Application.Height / 2 - Me.Height / 2 'Pour centrer sur l'application Application.Top + Application.Height / 2 - Me.Height / 2
End Function
Private Function férié(I)
Dim dat As Date, paques As Date, ctrlJ As Object, CF^
    Set ctrlJ = Calendar.Controls("J" & I)
    dat = 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
    Select Case region
        Case 13    'suisse
        If Weekday(DateSerial(Calendar.Cbyear, Calendar.Cbmonth.ListIndex + 1, ctrlJ.Caption), vbMonday) > 5 Then férié = btweekBack: CF = btweekfc
            Select Case True
            Case dat = CDate("01/01/" & Cbyear): férié = backfériéday: ctrlJ.ControlTipText = "Jour de l'an": CF = fériédayFC
            Case dat = CDate("02/01/" & Cbyear): férié = backfériéday: ctrlJ.ControlTipText = "Vaud et Jura": CF = fériédayFC
            Case dat = paques - 2: férié = backfériéday: ctrlJ.ControlTipText = "Vendredi saint": CF = fériédayFC
            Case dat = paques + 1: férié = backfériéday: ctrlJ.ControlTipText = "Lundi de paques": CF = fériédayFC
            Case dat = CDate("01/05/" & Cbyear.Value): férié = backfériéday: ctrlJ.ControlTipText = "Fête du travail": CF = fériédayFC
            Case dat = paques + 39: férié = backfériéday: ctrlJ.ControlTipText = "Ascension": CF = fériédayFC
            Case dat = paques + 40: férié = backfériéday: ctrlJ.ControlTipText = "Pont de l'ascension": CF = fériédayFC
            Case dat = CDate("01/08/" & Cbyear.Value): férié = backfériéday: ctrlJ.ControlTipText = "Fête Nationale": CF = fériédayFC
            Case dat = CDate("25/12/" & Cbyear): férié = backfériéday: ctrlJ.ControlTipText = "Noel": CF = fériédayFC
            Case dat = Date: férié = mobildayback: CF = mobildayFC: ctrlJ.ControlTipText = "Aujourd'hui"
        End Select
    End Select
    ctrlJ.ForeColor = CF
End Function
Private Sub BT_Annuler_Click()
    Unload Me
End Sub
Private Sub BT_Effacer_Click()
    Unload Me
    ActiveCell = ""
End Sub

[goninph]

Je progresse

Dans la feuille

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim DateFormats, DF 'Afficher le calendrier selon le format de la cellule
Application.ScreenUpdating = False
    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 = Calendar.ShowX(Target)
        End If
    Next
Application.ScreenUpdating = True
End Sub

Dans le testeur pour userform

Code :

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

1
2
3
Private Sub TextBox3_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    TextBox3 = Calendar.ShowX(TextBox3)
End Sub

Dans la fonction

Code :

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

1
2
'Public Function ShowX(Optional objX As Object, Optional Side As Long = 2, Optional Top As Long = 0, Optional optionRegionale As Long = 1000)
Public Function ShowX(Optional objX As Object)

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
Option Explicit
'Auteur: patricktoulon sur exceldownload - Version:4.1.9 maj : 26.11.2020-Modifié par Goninph 11.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 = Calendar.ShowX(Target)
'''''''        End If
'''''''    Next
'''''''End Sub
Dim bt1Back As Variant
Dim btweekfc As Variant
Dim btweekBack As Variant
Dim bt1fc As Variant
Dim mobildayback As Variant
Dim mobildayFC As Variant
Dim bt2Back As Variant
Dim backfériéday As Variant
Dim fériédayFC As Variant
Dim backDayRemonter As Variant
Public region
Public Obj As Object
Public oldvalue As Variant
Public WithEvents Bout As MSForms.CommandButton   'map pour 42 bouton
Public lance As Boolean
Public jour
Public mois
Public an
Public valeur As Date
Private clavier(43) As New Calendar    'tableau d'instance de l'userform
Public Function ShowX(Optional objX As Object)
Dim t#
Dim Forme
bt1Back = &HE0E0E0          'Couleur Background bouton jour
bt1fc = &H0&                'Couleur texte bouton jour
btweekBack = &H80000004     'Couleur Background bouton jour weekend
btweekfc = &H808080         'Couleur texte bouton jour weekend
mobildayback = &HC0FFFF     'Couleur Background bouton jour mobile
mobildayFC = &HFF0000       'Couleur texte jour mobile
bt2Back = &H80000004        'Couleur Background boutons jour vide
backfériéday = &HC0C0FF     'Couleur Background boutons jour férié
fériédayFC = &H0&           'Couleur texte bouton jour férié
backDayRemonter = &H80C0FF  'Couleur Background bouton jour de la cellule ou usf
    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.Left + Application.Width / 2 - Me.Width / 2 'Pour centrer sur l'application Application.Left + Application.Width / 2 - Me.Width / 2
    Me.Top = Application.Top + Application.Height / 2 - Me.Height / 2 'Pour centrer sur l'application Application.Top + Application.Height / 2 - Me.Height / 2
    Me.Show
    If TypeName(Obj) = "Range" Then
        valeur = DateSerial(an, mois, jour)
    Else
        valeur = format(DateSerial(an, mois, jour), Forme)
    End If
        ShowX = valeur 'On modifie  valeur apres le show
    Unload Me
    oldvalue = ""
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
    config
    Me.Caption = "Calendrier - Suisse": ldate.Caption = "Aujourd'hui " & format(Date, "dddd dd.mm.yyyy")
    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
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = 0 Then
        Cancel = True
        valeur = oldvalue
        Me.Hide
    Else
        Cancel = False
    End If
End Sub
'Evenement unique pour 42 boutons
Private Sub Bout_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    With Calendar: .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 Calendar.region = 1000 Then Calendar.region = Application.International(xlDateOrder)    'AUTOMATIQUE SYSTEM
    Calendar.Cbmonth.List = Split("Janvier, Février, Mars, Avril, Mai, Juin, Juillet, Août, Septembre, Octobre, Novembre, Décembre", ",")
    La_Date = Date
    Calendar.Cbmonth.ListIndex = Month(La_Date) - 1
    For i = 2023 To Year(La_Date) + 20: Calendar.Cbyear.AddItem i: Next
    SpinButton1.Value = Month(La_Date): SpinButton2.Value = Year(La_Date)
    ReloadClavier
    Me.Repaint
End Sub
Sub config()
    Dim Listdays, La_Date, i&
    Calendar.region = 13
    Calendar.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 = IIf(Calendar.region = 0 And TypeName(Obj) <> "Range", format(Obj.Value, "mm/dd/yyyy"), CDate(Obj.Value))
            oldvalue = La_Date
        Else
            La_Date = Date
            oldvalue = La_Date
        End If
    End If
    Calendar.Cbmonth.ListIndex = Month(La_Date) - 1
    For i = 2023 To Year(La_Date) + 20: Calendar.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
Private Sub SpinButton2_Change(): Cbyear.Value = SpinButton2.Value: End Sub
Private Sub Cbmonth_Change(): SpinButton1.Value = Cbmonth.ListIndex + 1: Calendar.ReloadClavier: End Sub
Private Sub Cbyear_Change(): SpinButton2.Value = Cbyear.Value: Calendar.ReloadClavier: 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 Calendar.region
    Case 0, 22: WkD = vbSunday
    Case 1, 2, 12, 13: WkD = vbMonday
    End Select
    X = Weekday(DateSerial(Calendar.Cbyear, Calendar.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 Calendar.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(Calendar.Cbyear.Value, Calendar.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
    Set ctrlJ = Calendar.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 = ActiveCell
    Select Case region
        Case 13    'suisse
        If Weekday(DateSerial(Calendar.Cbyear, Calendar.Cbmonth.ListIndex + 1, ctrlJ.Caption), vbMonday) > 5 Then férié = btweekBack: CF = btweekfc
            Select Case True
            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 + 1: férié = backfériéday: ctrlJ.ControlTipText = "Lundi de paques": 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é = backfériéday: ctrlJ.ControlTipText = "Pont de l'ascension": 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("25/12/" & Cbyear): férié = backfériéday: ctrlJ.ControlTipText = "Noel": 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 BT_Annuler_Click()
    Unload Me
End Sub
Private Sub BT_Effacer_Click()
    ActiveCell = ""
    Unload Me
End Sub

[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

Je vous joins le fichier Excel

Merci pour votre aide

[goninph]

J'ai enfin trouvé la parade pour fermer le formulaire et effacer la date

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

Des idées ? Merci d'avance

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
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 = Calendar.ShowX(Target)
'''''''        End If
'''''''    Next
'''''''End Sub
'A copier dans un userform
'''''''Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'''''''    TextBox1 = Calendar.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
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 Calendar    '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.Left + Application.Width / 2 - Me.Width / 2 'Pour centrer sur l'application Application.Left + Application.Width / 2 - Me.Width / 2
    Me.Top = Application.Top + Application.Height / 2 - Me.Height / 2 'Pour centrer sur l'application Application.Top + Application.Height / 2 - Me.Height / 2
    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
    config
    Me.Caption = "Calendrier - Suisse": ldate.Caption = "Aujourd'hui " & format(Date, "dddd dd.mm.yyyy")
    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&
    Calendar.region = 13
    Calendar.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
    Calendar.Cbmonth.ListIndex = Month(La_Date) - 1
    For i = 2023 To Year(La_Date) + 20: Calendar.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 Calendar: .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 Calendar.region = 1000 Then Calendar.region = Application.International(xlDateOrder)    'AUTOMATIQUE SYSTEM
    Calendar.Cbmonth.List = Split("Janvier, Février, Mars, Avril, Mai, Juin, Juillet, Août, Septembre, Octobre, Novembre, Décembre", ",")
    La_Date = Date
    Calendar.Cbmonth.ListIndex = Month(La_Date) - 1
    For i = 2023 To Year(La_Date) + 20: Calendar.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
Private Sub SpinButton2_Change(): Cbyear.Value = SpinButton2.Value: End Sub
Private Sub Cbmonth_Change(): SpinButton1.Value = Cbmonth.ListIndex + 1: Calendar.ReloadClavier: End Sub
Private Sub Cbyear_Change(): SpinButton2.Value = Cbyear.Value: Calendar.ReloadClavier: 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 Calendar.region
    Case 0, 22: WkD = vbSunday
    Case 1, 2, 12, 13: WkD = vbMonday
    End Select
    X = Weekday(DateSerial(Calendar.Cbyear, Calendar.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 Calendar.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(Calendar.Cbyear.Value, Calendar.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
    Set ctrlJ = Calendar.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 = ActiveCell
    Select Case region
        Case 13    'suisse
        If Weekday(DateSerial(Calendar.Cbyear, Calendar.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 + 1: férié = backfériéday: ctrlJ.ControlTipText = "Lundi de paques": 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é = backfériéday: ctrlJ.ControlTipText = "Pont de l'ascension": 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("25/12/" & Cbyear): férié = backfériéday: ctrlJ.ControlTipText = "Noel": 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 BT_Fermer_Click() 'Ferme avec l'ancienne valeur
   With Calendar: .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 Calendar: .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 Calendar: .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]

Malheureusement, bien qu'il fasse le taff, le source de ce formulaire n'est pas si bon que cela.
- Absence de types nombreuses.
- Plus complexe que nécessaire (formulaire récursif, code volontairement obscure).
- Viol du SRP.
- Viol de la loi de Demeter.

Je pense que ce que tu cherches se trouve dans la fonction ReloadClavier(), mais Bonjour pour comprendre ...