Calendrier par mois vba access

Soyez le premier à donner votre avis sur cette source.

Vue 30 186 fois - Téléchargée 2 659 fois

Description

Ce calendrier a été développé du fait que le contrôle déjà existant d'Access ne me permettait pas d'avoir toutes les fonctionnalités que je désirais. Suite à une recherche non concluante sur le net, j'ai décidé de dévelloper mon propre calendrier.

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

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

- Le calendrier dispose de 42 cases qui comprennent les derniers jours du mois précédent, les jours du mois en cours et les premiers jours du mois suivant.

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

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

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

Source / Exemple :


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
    Dim Bouton_Jour As Object
    
    '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 = Format$(Me.OpenArgs, "MM\/DD\/YYYY") 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)
    
    'On met le titre du mois et de l'année à jour
    Me.MonthYear.Caption = Me.Liste_Mois.Column(1) & " " & Me.Liste_Annee
        
    'On sélectionne la case relative à la date du jour
    i = (Weekday(DateSerial(Liste_Annee, Liste_Mois, 1)) - 1)
    If i = 0 Then i = 7
    If i = 1 Then i = 8
    i = i + CInt(Day(Jour_init)) - 1
    
    'On initialise la variable d'élément selectionné au bouton du jour
    Set Bouton_Jour = NumObject(i)
    With Bouton_Jour
        Set elem_selected = Bouton_Jour
    End With

    '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
    '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
    '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
Private Sub J8_Click()
    If Me.J8.SpecialEffect = 0 Then
        SelectDay (8)
    End If
End Sub
Private Sub J9_Click()
    If Me.J9.SpecialEffect = 0 Then
        SelectDay (9)
    End If
End Sub
Private Sub J10_Click()
    If Me.J10.SpecialEffect = 0 Then
        SelectDay (10)
    End If
End Sub
Private Sub J11_Click()
    If Me.J11.SpecialEffect = 0 Then
        SelectDay (11)
    End If
End Sub
Private Sub J12_Click()
    If Me.J12.SpecialEffect = 0 Then
        SelectDay (12)
    End If
End Sub
Private Sub J13_Click()
    If Me.J13.SpecialEffect = 0 Then
        SelectDay (13)
    End If
End Sub
Private Sub J14_Click()
    If Me.J14.SpecialEffect = 0 Then
        SelectDay (14)
    End If
End Sub
Private Sub J15_Click()
    If Me.J15.SpecialEffect = 0 Then
        SelectDay (15)
    End If
End Sub
Private Sub J16_Click()
    If Me.J16.SpecialEffect = 0 Then
        SelectDay (16)
    End If
End Sub
Private Sub J17_Click()
    If Me.J17.SpecialEffect = 0 Then
        SelectDay (17)
    End If
End Sub
Private Sub J18_Click()
    If Me.J18.SpecialEffect = 0 Then
        SelectDay (18)
    End If
End Sub
Private Sub J19_Click()
    If Me.J19.SpecialEffect = 0 Then
        SelectDay (19)
    End If
End Sub
Private Sub J20_Click()
    If Me.J20.SpecialEffect = 0 Then
        SelectDay (20)
    End If
End Sub
Private Sub J21_Click()
    If Me.J21.SpecialEffect = 0 Then
        SelectDay (21)
    End If
End Sub
Private Sub J22_Click()
    If Me.J22.SpecialEffect = 0 Then
        SelectDay (22)
    End If
End Sub
Private Sub J23_Click()
    If Me.J23.SpecialEffect = 0 Then
        SelectDay (23)
    End If
End Sub
Private Sub J24_Click()
    If Me.J24.SpecialEffect = 0 Then
        SelectDay (24)
    End If
End Sub
Private Sub J25_Click()
    If Me.J25.SpecialEffect = 0 Then
        SelectDay (25)
    End If
End Sub
Private Sub J26_Click()
    If Me.J26.SpecialEffect = 0 Then
        SelectDay (26)
    End If
End Sub
Private Sub J27_Click()
    If Me.J27.SpecialEffect = 0 Then
        SelectDay (27)
    End If
End Sub
Private Sub J28_Click()
    If Me.J28.SpecialEffect = 0 Then
        SelectDay (28)
    End If
End Sub
Private Sub J29_Click()
    If Me.J29.SpecialEffect = 0 Then
        SelectDay (29)
    End If
End Sub
Private Sub J30_Click()
    If Me.J30.SpecialEffect = 0 Then
        SelectDay (30)
    End If
End Sub
Private Sub J31_Click()
    If Me.J31.SpecialEffect = 0 Then
        SelectDay (31)
    End If
End Sub
Private Sub J32_Click()
    If Me.J32.SpecialEffect = 0 Then
        SelectDay (32)
    End If
End Sub
Private Sub J33_Click()
    If Me.J33.SpecialEffect = 0 Then
        SelectDay (33)
    End If
End Sub
Private Sub J34_Click()
    If Me.J34.SpecialEffect = 0 Then
        SelectDay (34)
    End If
End Sub
Private Sub J35_Click()
    If Me.J35.SpecialEffect = 0 Then
        SelectDay (35)
    End If
End Sub
Private Sub J36_Click()
    If Me.J36.SpecialEffect = 0 Then
        SelectDay (36)
    End If
End Sub
Private Sub J37_Click()
    If Me.J37.SpecialEffect = 0 Then
        SelectDay (37)
    End If
End Sub
Private Sub J38_Click()
    If Me.J38.SpecialEffect = 0 Then
        SelectDay (38)
    End If
End Sub
Private Sub J39_Click()
    If Me.J39.SpecialEffect = 0 Then
        SelectDay (39)
    End If
End Sub
Private Sub J40_Click()
    If Me.J40.SpecialEffect = 0 Then
        SelectDay (40)
    End If
End Sub
Private Sub J41_Click()
    If Me.J41.SpecialEffect = 0 Then
        SelectDay (41)
    End If
End Sub
Private Sub J42_Click()
    If Me.J42.SpecialEffect = 0 Then
        SelectDay (42)
    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 DateDebutMois As Date
    Dim k As Integer
    Dim Bouton_Jour As Object
        
    'On calcule k, le nb de jour du mois précédent à afficher sur le calendrier
    If Weekday(DateSerial(Liste_Annee, Liste_Mois, 1)) - 1 = 0 Then
        k = 7
    ElseIf Weekday(DateSerial(Liste_Annee, Liste_Mois, 1)) - 1 = 1 Then
        k = 8
    Else
        k = Weekday(DateSerial(Liste_Annee, Liste_Mois, 1) - 1)
    End If
    
    'On calcule le numéro du premier jour du mois précédent selon la date selectionnée grâce aux listes et le k
    DateDebutMois = DateAdd("d", -k + 1, DateSerial(Liste_Annee, Liste_Mois, 1))
    
    For i = 0 To 41
        'Pour chaque jours de la semaine
        Set Bouton_Jour = NumObject(i + 1)
        With Bouton_Jour
            'On affecte à la case en cours le numéro de son jour
            .Caption = Day(DateAdd("d", i, DateDebutMois))
            '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, DateDebutMois))) <> Liste_Mois Then
                .ForeColor = 8421504
            Else
                .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 + 2) Mod 7 = 0) Or ((i + 1) Mod 7 = 0) Or IsFerie(DateAdd("d", i, DateDebutMois)) Then
                .BackColor = NotWorkedColor
            Else
                .BackColor = NormalColor
            End If
        End With
    Next
    
    'On donne au bouton selectionné les attributs de la selection (couleur, aspect, etc...)
    With elem_selected
        .SpecialEffect = 2
        'Dans le cas d'une case "WE" ou fériée, on sauvegarde la bonne couleur
        If ((((CInt(Right(.Name, Len(.Name) - 1)) + 1) Mod 7) = 0 Or (CInt(Right(.Name, Len(.Name) - 1)) Mod 7) = 0)) Then
            text_color_old = NotWorkedColor
        Else
            text_color_old = .BackColor
        End If
        .BackColor = SelectColor
    End With
End Function

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

Private Function DeSelectPreviousDay()
    With elem_selected
        .SpecialEffect = 0
        .BackColor = text_color_old
    End With
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
    Set Bouton_Jour(8) = Me.J8
    Set Bouton_Jour(9) = Me.J9
    Set Bouton_Jour(10) = Me.J10
    Set Bouton_Jour(11) = Me.J11
    Set Bouton_Jour(12) = Me.J12
    Set Bouton_Jour(13) = Me.J13
    Set Bouton_Jour(14) = Me.J14
    Set Bouton_Jour(15) = Me.J15
    Set Bouton_Jour(16) = Me.J16
    Set Bouton_Jour(17) = Me.J17
    Set Bouton_Jour(18) = Me.J18
    Set Bouton_Jour(19) = Me.J19
    Set Bouton_Jour(20) = Me.J20
    Set Bouton_Jour(21) = Me.J21
    Set Bouton_Jour(22) = Me.J22
    Set Bouton_Jour(23) = Me.J23
    Set Bouton_Jour(24) = Me.J24
    Set Bouton_Jour(25) = Me.J25
    Set Bouton_Jour(26) = Me.J26
    Set Bouton_Jour(27) = Me.J27
    Set Bouton_Jour(28) = Me.J28
    Set Bouton_Jour(29) = Me.J29
    Set Bouton_Jour(30) = Me.J30
    Set Bouton_Jour(31) = Me.J31
    Set Bouton_Jour(32) = Me.J32
    Set Bouton_Jour(33) = Me.J33
    Set Bouton_Jour(34) = Me.J34
    Set Bouton_Jour(35) = Me.J35
    Set Bouton_Jour(36) = Me.J36
    Set Bouton_Jour(37) = Me.J37
    Set Bouton_Jour(38) = Me.J38
    Set Bouton_Jour(39) = Me.J39
    Set Bouton_Jour(40) = Me.J40
    Set Bouton_Jour(41) = Me.J41
    Set Bouton_Jour(42) = Me.J42
    
    'On retourne l'objet correspondant au paramètre
    Set NumObject = Bouton_Jour(j)
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 DateDebutMois As Date
    Dim i As Integer
    'On calcule i, le nb de jour du mois précédent à afficher sur le calendrier
    If Weekday(DateSerial(Liste_Annee, Liste_Mois, 1)) - 1 = 0 Then
        i = 7
    ElseIf Weekday(DateSerial(Liste_Annee, Liste_Mois, 1)) - 1 = 1 Then
        i = 8
    Else
        i = Weekday(DateSerial(Liste_Annee, Liste_Mois, 1) - 1)
    End If
    
    'On calcule le numéro du premier jour du mois précédent selon la date selectionnée grâce aux listes et le k
    DateDebutMois = DateAdd("d", -i + 1, DateSerial(Liste_Annee, Liste_Mois, 1))
    'On récupère le numéro de la case
    With elem_selected
        i = CInt(Right(.Name, Len(.Name) - 1))
    End With
    'On calcule la date de la case selectionnée et on la renvoie
    ReturnDate = DateAdd("d", i - 1, DateDebutMois)
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, AA, MM As Integer
    Dim NbOr, Epacte As Integer
    Dim PLune, Paques, Ascension, 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

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

Messages postés
1
Date d'inscription
mardi 23 février 2010
Statut
Membre
Dernière intervention
3 mars 2010

L'auteur (Pillsmen) a effectué un travail remarquable. Pillsmen, avez-vous perfectionné l'application en permettant l'affichage de données d'une table dans les cellules ? Salutations et merci.
Messages postés
3
Date d'inscription
mardi 22 janvier 2008
Statut
Membre
Dernière intervention
31 janvier 2008

Ce calendrier est exactement ce que je cherchais.
mais le petit problème c'est que je débute totalement sur access. Ca fait un petit moment que je cherche mais j'arrive pas a trouver comment on fait afficher des infos dans les cases des jours.
C'est en fait pour faire un formulaire de prise de rendez vous avec affichage sous forme de calendrier.
Merci
Messages postés
1
Date d'inscription
vendredi 8 septembre 2006
Statut
Membre
Dernière intervention
21 août 2007

Félicitations pour ce calendrier, je recherchai depuis quelques temps déjà ce type de programme pour avancé dans la gestion d'un planning avec des repos décalés piloté par access

Encore bravo et merci
Messages postés
27
Date d'inscription
samedi 27 mai 2006
Statut
Membre
Dernière intervention
3 juillet 2007

Merci DavidDech. Le bug a été corrigé sans passer par une variable globale ;)

Par ailleurs, suite aux remarques d'une autre source : http://www.vbfrance.com/codes/FORMAT-DATE-SYSTEM-PORTABILITE_43286.aspx (Merci Renfield), j'ai changer ce code de manière à ce qu'il soit exploitable quelque soit la région dans laquelle on se trouve (format de dates différents)
Messages postés
1
Date d'inscription
mercredi 6 juin 2007
Statut
Membre
Dernière intervention
16 juin 2007

J'ai remarqué un petit bug lorsque le premier jour du mois est un lundi.
Lorsque l'on clique sur une date, il est retourné la date + 7 jours.
C'est le cas par exemple pour les mois de janvier et décembre 2007.
Si l'on clique sur 1er janvier, la date retournée est le 8 janvier.
J'ai corrigé ce bug en déclarant la variable k publique et en modifiant légèrement de code de la fonction ReturnDate comme ceci :

'On calcule la date de la case selectionnée et on la renvoie
If k = 8 Then
ReturnDate = DateAdd("d", i - 8, DateDebutMois)
Else
ReturnDate = DateAdd("d", i - 1, DateDebutMois)
End If
A part cette petite anomalie, excellent travail. J'ai pu en effectuant quelques retouches remplacer le calendrier office qui ne fonctionne pas sur toutes les configurations de PC.
Afficher les 10 commentaires

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.