CALENDRIER PAR SEMAINE VBA ACCESS

---

Commentaire sur cette source (15)
Ajouter un commentaire et/ou une note

Calendrier par semaine entièrement géré par vba.
Il reprend les fonctionnalités du calendrier par mois que j'ai codé (source : http://www.vbfrance.com/code.aspx?ID=42460) à savoir :

Celui-ci reprend l'aspect du contrôle Calendrier xx.x intégré à Microsoft Access :

- Trois zones de liste déroulante permettent de sélectionner le jour, le mois et l'année désirés

- Le calendrier dispose de 7 cases qui comprennent les jours de la semaine du jour sélectionné ainsi que les premiers jours  du mois précédent ou les derniers jours du mois suivant

- Coloration des jours fériés (fixes et mobiles) ainsi que les WE

- Affichage du numéro de la semaine en cours

- La couleur du texte utilisée pour les jours du mois en cours est différente de celle utilisée pour les mois précédent et suivant afin de faire la différence.

- Effet "enfoncé" lors de la sélection d'un jour

- Fonction qui retourne la date sélectionnée

- Les années bissextiles sont prises en compte

- Etc...

A la différence du contrôle calendrier, ce calendrier (entièrement géré en vba) permet de colorer les jours, d'y insérer du texte etc... (les jours sont modélisés par des Etiquettes)

Il est initialisés à la date du jour.

Le code est bien commenté permettant une facile compréhension et facilitant les modifications !!!

Option Compare Database
Option Explicit
'Sauvegarde de l'élément en cour de selection
Public elem_selected As Object
'Sauvegarde de la couleur de fond de l'élément avant sa sélection
Public text_color_old As Long
'Couleur de sélection par défaut
Const SelectColor = 12632256
'Couleur des jours non ouvrés (WE + fériés) par défaut
Const NotWorkedColor = 15987699
'Couleur "normale"
Const NormalColor = 16777215

Private Sub Form_Load()
    Dim i As Integer
    
    'On récupère l'argument de l'ouverture du calendrier s'il y en a un et on sélectionne les bonnes valeurs de jour, mois, année.
    'S'il n'y a pas d'argument, on initialise le calendrier à la date du jour
    Dim Jour_init As Date
    If Not IsNull(Me.OpenArgs) Then Jour_init = Me.OpenArgs Else Jour_init = Date
    
    'Initialisation des listes déroulantes du mois et de l'année
    Me.Liste_Mois.RowSource = "1;Janvier;2;Février;3;Mars;4;Avril;5;Mai;6;Juin;7;Juillet;8;Août;9;Septembre;10;Octobre;11;Novembre;12;Décembre"
    Me.Liste_Annee.RowSource = ""
    For i = 1900 To CInt(Year(Date)) + 100
        Me.Liste_Annee.AddItem (CStr(i))
    Next
    
    'Selection du mois et de l'année en cours
    Liste_Mois = Liste_Mois.ItemData(CInt(Month(Jour_init)) - 1)
    Liste_Annee = Liste_Annee.ItemData(CInt(Year(Jour_init)) - 1900)
    
    'Initialisation de la liste déroulante des jours
    Me.Liste_Jour.RowSource = ""
    For i = 1 To Nbjour_mois(Liste_Mois, Liste_Annee)
        Me.Liste_Jour.AddItem (i)
    Next
        
    'Selection du jour en cours
    Liste_Jour = Liste_Jour.ItemData(CInt(Day(Jour_init)) - 1)
        
    'On met le titre du mois et de l'année à jour ainsi que le numéro de la semaine
    Me.MonthYear.Caption = Me.Liste_Mois.Column(1) & " " & Me.Liste_Annee
    Me.WeekNum.Caption = "Semaine " & DatePart("ww", DateSerial(Me.Liste_Annee, Me.Liste_Mois, Me.Liste_Jour), vbMonday, vbFirstFourDays)
    
        
    'On calcule le numéro de la case du jour en cours
    i = (Weekday(Jour_init) - 1)
    If i = 0 Then i = 7

    'On initialise la variable d'élément selectionné au bouton du jour
    Set elem_selected = NumObject(i)

    'On initialise le calcul des jours (jours associés à la date)
    CalculJours
    
End Sub

Private Sub Liste_Annee_AfterUpdate()
    'On réactualise le titre (mois + année)
    Me.MonthYear.Caption = Me.Liste_Mois.Column(1) & " " & Me.Liste_Annee
    
    Dim Num As Integer, i As Integer
    Num = Me.Liste_Jour.OldValue
    'On réactualise la liste des jours (pour les années bissextiles !)
    Me.Liste_Jour.RowSource = ""
    For i = 1 To Nbjour_mois(Liste_Mois, Liste_Annee)
        Me.Liste_Jour.AddItem (i)
    Next
    'Si le mois qui été selectionné précédemment possède plus de jour que le mois que l'on vient de choisir, on prend le dernier jour de ce dernier
    '(exemple :date sélectionnée = '31/03/07', mois que l'on va sélectionner = 'xx/02/07', on aura '28/02/07'
    If Me.Liste_Jour.ItemData(Num - 1) > Nbjour_mois(Me.Liste_Mois, Me.Liste_Annee) Then Me.Liste_Jour = Me.Liste_Jour.ItemData(Nbjour_mois(Me.Liste_Mois, Me.Liste_Annee) - 1) Else Me.Liste_Jour = Me.Liste_Jour.ItemData(Num - 1)
    
    'On réactualise le numéro de semaine
    Me.WeekNum.Caption = "Semaine " & DatePart("ww", DateSerial(Me.Liste_Annee, Me.Liste_Mois, Me.Liste_Jour), vbMonday, vbFirstFourDays)
    'On réinitialise le calcul des jours (jours associés à la date)
    CalculJours
    
End Sub

Private Sub Liste_Mois_Change()
    'On réactualise le titre (mois + année)
    Me.MonthYear.Caption = Me.Liste_Mois.Column(1) & " " & Me.Liste_Annee

    Dim Num As Integer, i As Integer
    Num = Me.Liste_Jour.OldValue
    'On réactualise la liste des jours
    Me.Liste_Jour.RowSource = ""
    For i = 1 To Nbjour_mois(Liste_Mois, Liste_Annee)
        Me.Liste_Jour.AddItem (i)
    Next
    'Si le mois qui été selectionné précédemment possède plus de jour que le mois que l'on vient de choisir, on prend le dernier jour de ce dernier
    '(exemple :date sélectionnée = '31/03/07', mois que l'on va sélectionner = 'xx/02/07', on aura '28/02/07'
    If Me.Liste_Jour > Nbjour_mois(Me.Liste_Mois, Me.Liste_Annee) Then
        Me.Liste_Jour = Me.Liste_Jour.ItemData(Nbjour_mois(Me.Liste_Mois, Me.Liste_Annee) - 1)
    Else
        Me.Liste_Jour = Num
    End If
    'On réactualise le numéro de semaine
    Me.WeekNum.Caption = "Semaine " & DatePart("ww", DateSerial(Me.Liste_Annee, Me.Liste_Mois, Me.Liste_Jour), vbMonday, vbFirstFourDays)
    
    'On réinitialise le calcul des jours (jours associés à la date)
    CalculJours
End Sub

Private Sub Liste_jour_Change()
    'On réactualise le numéro de semaine
    Me.WeekNum.Caption = "Semaine " & DatePart("ww", DateSerial(Me.Liste_Annee, Me.Liste_Mois, Me.Liste_Jour), vbMonday, vbFirstFourDays)
    
    'On réinitialise le calcul des jours (jours associés à la date)
    CalculJours
End Sub

Private Sub Previous_Click()
    Dim date_prec As Date
    date_prec = DateAdd("ww", -1, DateSerial(Me.Liste_Annee, Me.Liste_Mois, Me.Liste_Jour))
    
    'On sélectionne la semaine qui précède la semaine en cours
    Liste_Annee = Liste_Annee.ItemData(CInt(Year(date_prec)) - 1900)
    Liste_Mois = Liste_Mois.ItemData(CInt(Month(date_prec)) - 1)
    Dim Num As Integer, i As Integer
    Num = Me.Liste_Jour.OldValue
    'On réactualise la liste des jours
    Me.Liste_Jour.RowSource = ""
    For i = 1 To Nbjour_mois(Liste_Mois, Liste_Annee)
        Me.Liste_Jour.AddItem (i)
    Next
    Me.Liste_Jour = Liste_Jour.ItemData(CInt(Day(date_prec)) - 1)
    'On réactualise le titre (mois + année)
    Me.MonthYear.Caption = Me.Liste_Mois.Column(1) & " " & Me.Liste_Annee
    'On réactualise le numéro de semaine
    Me.WeekNum.Caption = "Semaine " & DatePart("ww", DateSerial(Me.Liste_Annee, Me.Liste_Mois, Me.Liste_Jour), vbMonday, vbFirstFourDays)
    
    'On réinitialise le calcul des jours (jours associés à la date)
    CalculJours
    
End Sub

Private Sub Next_Click()
    Dim date_prec As Date
    date_prec = DateAdd("ww", 1, DateSerial(Me.Liste_Annee, Me.Liste_Mois, Me.Liste_Jour))
    
    'On sélectionne la semaine qui précède la semaine en cours
    Liste_Annee = Liste_Annee.ItemData(CInt(Year(date_prec)) - 1900)
    Liste_Mois = Liste_Mois.ItemData(CInt(Month(date_prec)) - 1)
    Dim Num As Integer, i As Integer
    Num = Me.Liste_Jour.OldValue
    'On réactualise la liste des jours
    Me.Liste_Jour.RowSource = ""
    For i = 1 To Nbjour_mois(Liste_Mois, Liste_Annee)
        Me.Liste_Jour.AddItem (i)
    Next
    Me.Liste_Jour = Liste_Jour.ItemData(CInt(Day(date_prec)) - 1)
    'On réactualise le titre (mois + année)
    Me.MonthYear.Caption = Me.Liste_Mois.Column(1) & " " & Me.Liste_Annee
    'On réactualise le numéro de semaine
    Me.WeekNum.Caption = "Semaine " & DatePart("ww", DateSerial(Me.Liste_Annee, Me.Liste_Mois, Me.Liste_Jour), vbMonday, vbFirstFourDays)
    
    
    'On réinitialise le calcul des jours (jours associés à la date)
    CalculJours
    
End Sub

'Procédure évènementielle de chaque case du calendrier
'Lorsque l'on clique, on rend la couleur et l'aspect d'origine à la case qui était selectionnée avant
'et on donne l'aspect "appuyé" et la couleur de fond à la case "en cour"

Private Sub J1_Click()
    If Me.J1.SpecialEffect = 0 Then
        SelectDay (1)
    End If
End Sub
Private Sub J2_Click()
    If Me.J2.SpecialEffect = 0 Then
        SelectDay (2)
    End If
End Sub
Private Sub J3_Click()
    If Me.J3.SpecialEffect = 0 Then
        SelectDay (3)
    End If
End Sub
Private Sub J4_Click()
    If Me.J4.SpecialEffect = 0 Then
        SelectDay (4)
    End If
End Sub
Private Sub J5_Click()
    If Me.J5.SpecialEffect = 0 Then
        SelectDay (5)
    End If
End Sub
Private Sub J6_Click()
    If Me.J6.SpecialEffect = 0 Then
        SelectDay (6)
    End If
End Sub
Private Sub J7_Click()
    If Me.J7.SpecialEffect = 0 Then
        SelectDay (7)
    End If
End Sub
'Cette fonction permet le calcul des dates par jour, une fois le premier jour du mois ainsi que "sa case" ait été détectés,
'on remplit les premières cases avec les numéros des jours du mois précédent, puis on continue avec les cases du mois en cours
'pour finir avec les jours du mois suivant
Private Function CalculJours()
    Dim i As Integer
    Dim DateDebutSemaine As Date
    Dim k As Integer
    
    'On calcule le numéro du premier jour de la semaine selon la date selectionnée grâce aux listes
    DateDebutSemaine = DateAdd("d", -IIf(Weekday(DateSerial(Me.Liste_Annee, Me.Liste_Mois, Me.Liste_Jour)) - 1 = 0, 7, Weekday(DateSerial(Me.Liste_Annee, Me.Liste_Mois, Me.Liste_Jour)) - 1) + 1, DateSerial(Me.Liste_Annee, Me.Liste_Mois, Me.Liste_Jour))
    
    'Pour chaque jours de la semaine
    For i = 0 To 6
        'On affecte à la case en cours le numéro de son jour
        NumObject(i + 1).Caption = Day(DateAdd("d", i, DateDebutSemaine))
        
        'Et on colore la police des cases du mois en cours différemment des cases du mois précédent et suivant
        If CInt(Month(DateAdd("d", i, DateDebutSemaine))) <> Liste_Mois Then
            NumObject(i + 1).ForeColor = 8421504
        Else
            NumObject(i + 1).ForeColor = 10485760
            
        End If
        
        'On colore l'arrière plan des cases qui sont des samedi, dimanche, ou des jours fériés
        If (i = 5) Or (i = 6) Or IsFerie(DateAdd("d", i, DateDebutSemaine)) Then
            NumObject(i + 1).BackColor = NotWorkedColor
        Else
            NumObject(i + 1).BackColor = NormalColor
        End If
    Next
    'Dans le cas d'une case "WE" ou fériée, on sauvegarde la bonne couleur
    If ((CInt(elem_selected.Caption) = 6) Or (CInt(elem_selected.Caption) = 7)) Then
        text_color_old = NotWorkedColor
    Else
        text_color_old = elem_selected.BackColor
    End If
    'On donne au bouton selectionné les attributs de la selection (couleur, aspect, etc...)
    elem_selected.BackColor = SelectColor
End Function

Public Function SelectDay(num_case As Integer)
    DeSelectPreviousDay
    'Sauvegarde de la couleur de la case
    text_color_old = NumObject(num_case).BackColor
    NumObject(num_case).BackColor = SelectColor
    NumObject(num_case).SpecialEffect = 2
    'Mise à jour de la variable case en cour de sélection
    Set elem_selected = NumObject(num_case)
    MsgBox ReturnDate
End Function

Private Function DeSelectPreviousDay()
    elem_selected.SpecialEffect = 0
    elem_selected.BackColor = text_color_old
    Set elem_selected = Nothing
End Function


'Cette fonction permet de contourner l'interdiction d'avoir une variable tableau public
'Elle retourne un objet qui désigne une case du calendrier en fonction de sa position (facilement calculable)
Private Function NumObject(j As Integer) As Object
    Dim Bouton_Jour(42) As Object
    
    'On initialise le tableau d'objets
    Set Bouton_Jour(1) = Me.J1
    Set Bouton_Jour(2) = Me.J2
    Set Bouton_Jour(3) = Me.J3
    Set Bouton_Jour(4) = Me.J4
    Set Bouton_Jour(5) = Me.J5
    Set Bouton_Jour(6) = Me.J6
    Set Bouton_Jour(7) = Me.J7
    
    'On retourne l'objet correspondant au paramètre
    Set NumObject = Bouton_Jour(j)
End Function

'Fonction inverse
Private Function ObjectNum(Bouton_Jour As Object) As Integer
        
    'On initialise le tableau d'objets
    With Bouton_Jour
        Select Case Bouton_Jour.Name
            Case "J1"
                ObjectNum = 1
            Case "J2"
                ObjectNum = 2
            Case "J3"
                ObjectNum = 3
            Case "J4"
                ObjectNum = 4
            Case "J5"
                ObjectNum = 5
            Case "J6"
                ObjectNum = 6
            Case "J7"
                ObjectNum = 7
        End Select
    End With
End Function

'Fonction qui retourne la date de la case sélectionnée sous le format jj/mm/aaaa
Private Function ReturnDate() As Date
    Dim DateDebutSemaine As Date
    Dim i As Integer
    'On calcule le numéro du premier jour de la semaine selon la date selectionnée grâce aux listes
    DateDebutSemaine = DateAdd("d", -IIf(Weekday(DateSerial(Me.Liste_Annee, Me.Liste_Mois, Me.Liste_Jour)) - 1 = 0, 7, Weekday(DateSerial(Me.Liste_Annee, Me.Liste_Mois, Me.Liste_Jour)) - 1) + 1, DateSerial(Me.Liste_Annee, Me.Liste_Mois, Me.Liste_Jour))
    'On récupère le numéro de la case
    i = ObjectNum(elem_selected)
    'On calcule la date de la case selectionnée et on la renvoie
    ReturnDate = DateAdd("d", i - 1, DateDebutSemaine)
End Function

'Fonction trouvée sur www.codes-sources.fr/www.vbfrance.com
'http://www.vbfrance.com/code.aspx?ID=1251
Private Function IsFerie(Date_testee As Date) As Boolean
    Dim JJ As Integer, AA As Integer, MM As Integer
    Dim NbOr As Integer, Epacte As Integer
    Dim PLune As Date, Paques As Date, Ascension As Date, Pentecote As Date
    JJ = Day(Date_testee)
    MM = Month(Date_testee)
    AA = Year(Date_testee)
    If JJ = 1 And MM = 1 Then IsFerie = True: Exit Function '1 Janvier
    If JJ = 1 And MM = 5 Then IsFerie = True: Exit Function '1 Mai
    If JJ = 8 And MM = 5 Then IsFerie = True: Exit Function '8 Mai
    If JJ = 14 And MM = 7 Then IsFerie = True: Exit Function '14 Juillet
    If JJ = 15 And MM = 8 Then IsFerie = True: Exit Function '15 Août
    If JJ = 1 And MM = 11 Then IsFerie = True: Exit Function '1 Novembre
    If JJ = 11 And MM = 11 Then IsFerie = True: Exit Function '11 Novembre
    If JJ = 25 And MM = 12 Then IsFerie = True: Exit Function '25 Décembre
    NbOr = (AA Mod 19) + 1
    Epacte = (11 * NbOr - (3 + Int((2 + Int(AA / 100)) * 3 / 7))) Mod 30
    PLune = DateSerial(AA, 4, 19) - ((Epacte + 6) Mod 30)
    If Epacte = 24 Then PLune = PLune - 1
    If Epacte = 25 And (AA >= 1900 And AA < 2000) Then PLune = PLune - 1
    Paques = PLune - Weekday(PLune) + vbMonday + 7 'Paques
    If JJ = Day(Paques) And MM = Month(Paques) Then IsFerie = True: Exit Function
    Ascension = Paques + 38 'Ascension
    If JJ = Day(Ascension) And MM = Month(Ascension) Then IsFerie = True: Exit Function
    Pentecote = Ascension + 11 'Pentecote
    If JJ = Day(Pentecote) And MM = Month(Pentecote) Then IsFerie = True: Exit Function
    IsFerie = False
End Function

'Fonction qui retourne le numéro de la semaine selon une date donnée
Private Function NumeroSemaine(date_jour As Date) As Integer
    'Algorithme adapté à vb trouvé sur http://www.univ-lemans.fr/~hainry/articles/semaine.html
    Dim i As Integer, j As Integer, N As Integer, S As Integer, A As Integer
    N = 0
    For i = 1 To CInt(Month(date_jour)) - 1
        N = N + Nbjour_mois(i, CInt(Year(date_jour)))
    Next
    N = N + CInt(Day(date_jour))
    S = Fix(CInt(Year(date_jour)) / 100)
    A = CInt(Year(date_jour)) - S
    If Nbjour_mois(2, Year(date_jour)) <= 28 Then j = (5 * S + S / 4 + A + A / 4) Mod 7 Else j = (5 * S + S / 4 + A + A / 4 + 6) Mod 7
    NumeroSemaine = (j + N + 5) / 7 - (j / 5)
End Function

'Fonction qui retourne le nombre de jour par mois (années bissextiles prises en compte)
Private Function Nbjour_mois(Mois As Integer, Annee As Integer) As Integer
    Nbjour_mois = IIf(Mois > 7, 31 - Mois Mod 2, 30 + Mois Mod 2)
    If Mois = 2 Then
        Nbjour_mois = 28 + Sgn(IIf((Annee Mod 100) = 0, Annee Mod 400, Annee Mod 4)) Xor 1
    End If
End Function

Pour les "Membres Club", vous pouvez télécharger directement un fichier contenu dans le zip sans télécharger le zip en entier !

Télécharger le zip

09 mai 2007 11:06:21 :

Gestion des jours fériés

09 juillet 2007 09:47:09 :

Prise en compte des remarques, portabilité vers des formats de dates différents (pays étrangers)

• FORMAT DE DATE SYSTEM ET PORTABILITÉ
• CALENDRIER PAR MOIS VBA ACCESS

• FUSEAUX MATIC
• AVERTISSEUR
• CREATION DU VERSION SHAREWARE
• ERYGENDA ÉTERNEL OU PRESQUE. VERSION DE BASE, SANS ATTACHEMENTS À DES DOCUMENTS
• HORLOGE 2

• CONNEXION BASES DE DONNÉES
• CALENDRIER STYLE OUTLOOK
• CRÉATION ASSISTÉE PAR CODE DAO D’UNE TABLE DANS MS ACCESS – NOMBRE ET TYPE DE CHAMPS SELON LES BESOINS.
• ACCESS VBA ZIP UNZIP
• CALENDRIER PAR MOIS VBA ACCESS