Option Explicit Private Sub UserForm_Initialize() Dim Obj As Control Dim i As Integer, Mois As Integer, Annee As Integer Dim Cl As Classe1 'Création Changement de mois 'LABEL Set Collect = New Collection Set Obj = Me.Controls.Add("forms.Label.1") With Obj .Name = "LbChoixMois" .Object.Caption = "Choix du mois : " .Left = 5 .Top = 5 .Width = 70 .Height = 10 End With 'BOUTONS < et > Set Obj = Me.Controls.Add("forms.CommandButton.1") With Obj .Name = "MoisPrec" .Object.Caption = "<" .Left = 75 .Top = 1 .Width = 20 .Height = 20 End With Set Cl = New Classe1 Set Cl.Bouton = Obj Collect.Add Cl Set Obj = Me.Controls.Add("forms.CommandButton.1") With Obj .Name = "MoisSuiv" .Object.Caption = ">" .Left = 95 .Top = 1 .Width = 20 .Height = 20 End With Set Cl = New Classe1 Set Cl.Bouton = Obj Collect.Add Cl 'Création entête Jours de la semaine For i = 1 To 7 Set Obj = Me.Controls.Add("forms.Label.1") With Obj .Name = "Jour" & i .Object.Caption = UCase(Left(Format(DateSerial(2014, 9, i), "dddd"), 1)) .Left = 20 * (i - 1) + 5 .Top = 25 .Width = 20 .Height = 10 End With Next i 'création boutons "jours" Mois = Month(Date) MoisEnCours = Mois Annee = Year(Date) AnneeEnCours = Annee CreationBoutonsJours Mois, Annee If Left(Format(Date, "dd"), 1) = "0" Then Me.Controls("Bouton" & Format(Date, "d")).SetFocus Else Me.Controls("Bouton" & Format(Date, "dd")).SetFocus End Sub
Option Explicit Public WithEvents Bouton As MSForms.CommandButton Private Sub Bouton_Click() Select Case Bouton.Name Case "MoisPrec" MoisEnCours = MoisEnCours - 1 If MoisEnCours = 0 Then MoisEnCours = 12 AnneeEnCours = AnneeEnCours - 1 If AnneeEnCours = 1899 Then MoisEnCours = 1 AnneeEnCours = 1900 MsgBox "Première année : 1900" End If End If Case "MoisSuiv" MoisEnCours = MoisEnCours + 1 If MoisEnCours = 13 Then MoisEnCours = 1 AnneeEnCours = AnneeEnCours + 1 End If End Select CreationBoutonsJours MoisEnCours, AnneeEnCours End Sub
Option Explicit Public WithEvents Btn As MSForms.CommandButton 'Procédure lors du clic sur un bouton "jour" Private Sub Btn_Click() Dim maDate As Date maDate = CDate(Btn.Caption & "/" & Calendrier.Tag) 'La ligne suivante détermine l'action à effectuer lors d'un clic sur le bouton 'Pour entrer la date choisie dans une cellule et fermer l'Userform : 'ActiveCell.Value = maDate 'Unload Calendrier MsgBox maDate End Sub 'Affiche le nom du jour férié au survol du bouton par la souris Private Sub Btn_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) Dim maDate As Date maDate = CDate(Btn.Caption & "/" & Calendrier.Tag) If EstJourFerie(maDate) Or Paques(Year(maDate)) = maDate Then Btn.ControlTipText = QuelFerie(maDate) End Sub
Option Explicit Public WithEvents Btn As MSForms.CommandButton 'Procédure lors du clic sur un bouton "jour" Private Sub Btn_Click() Dim maDate As Date maDate = CDate(Btn.Caption & "/" & Calendrier.Tag) 'La ligne suivante détermine l'action à effectuer lors d'un clic sur le bouton 'Pour entrer la date choisie dans une cellule et fermer l'Userform : 'ActiveCell.Value = maDate 'Unload Calendrier MsgBox maDate End Sub 'Affiche le nom du jour férié au survol du bouton par la souris Private Sub Btn_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) Dim maDate As Date maDate = CDate(Btn.Caption & "/" & Calendrier.Tag) If EstJourFerie(maDate) Or Paques(Year(maDate)) = maDate Then Btn.ControlTipText = QuelFerie(maDate) End Sub
'Fonction qui retourne le jour férié en "String" 'utile pour les info-bulles au survol des jours fériés Public Function QuelFerie(Jour As Date) As String Dim maDate As Date Dim a As Integer, m As Integer, j As Integer maDate = Paques(Year(Jour)) If Jour = maDate Then QuelFerie = "Dimanche de Pâques": Exit Function If Jour = CDate(maDate + 1) Then QuelFerie = "Lundi de Pâques": Exit Function If Jour = CDate(maDate + 50) Then QuelFerie = "Lundi de Pentecôte": Exit Function If Jour = CDate(maDate + 39) Then QuelFerie = "Jeudi de l'ascension": Exit Function a = Year(Jour): m = Month(Jour): j = Day(Jour) Select Case m * 100 + j Case 101 QuelFerie = "1er Janvier": Exit Function Case 501 QuelFerie = "1er Mai": Exit Function Case 508 QuelFerie = "8 Mai": Exit Function Case 714 QuelFerie = "14 Juillet": Exit Function Case 815 QuelFerie = "15 Août": Exit Function Case 1101 QuelFerie = "1er Novembre": Exit Function Case 1111 QuelFerie = "11 Novembre": Exit Function Case 1225 QuelFerie = "Noël": Exit Function End Select End Function
'SOURCES : 'http://blog.developpez.com/philben/p11458/vba-access/sagit-il-dun-jour-ferie Public Function EstJourFerie(ByVal laDate As Date, Optional ByVal EstPentecoteFerie As Boolean = True) As Boolean 'Détermine si la date passée en argument est un jour férié (en France) ou non : ' 101 = 1er Janvier - 501 = 1er Mai - 508 = 8 Mai - 714 = 14 Juillet ' 815 = 15 Août - 1101 = 1er Novembre - 1111 = 11 Novembre - 1225 = 25 Décembre ' dPa = Lundi de Pâques - dAs = Jeudi de l'Ascension - dPe = Lundi de Pentecôte 'Remarque : Le lundi de Pentecôte est un jour férié mais parfois non chômé (EstPentecoteFerie = False dans ce cas) 'Philben - v1.0 - 2012 - Free to use Static Annee As Integer, dPa As Date, dAs As Date, dPe As Date, bPe As Boolean Dim a As Integer, m As Integer, j As Integer a = Year(laDate): m = Month(laDate): j = Day(laDate) Select Case m * 100 + j Case 101, 501, 508, 714, 815, 1101, 1111, 1225 EstJourFerie = True Case 323 To 614 '323: Date mini Lundi de Pâques - 614 : Date maxi Lundi de Pentecôte If a <> Annee Or EstPentecoteFerie <> bPe Then Annee = a: dPa = Paques(a) + 1: dAs = dPa + 38 bPe = EstPentecoteFerie: If bPe Then dPe = dPa + 49 Else dPe = #1/1/100# End If Select Case DateSerial(a, m, j): Case dPa, dAs, dPe: EstJourFerie = True: End Select End Select End Function
DON'T MISS