VBA Excel [toutes versions] - Contrôle calendrier transposable
Introduction
En VBA, le contrôle calendrier a changé entre les versions d'Excel 2003 et Excel 2010. Les anciennes versions comportent un contrôle nommé "Calendar", les nouvelles versions, le contrôle DT Picker.
Le souci de la portabilité d'un classeur que l'on créé, d'un ordinateur à un autre, se pose alors. Comment utiliser mon contrôle Calendar dans les nouvelles versions et comment utiliser le DT Picker dans les anciennes?
Un autre souci réside dans l'installation de votre pack Office. Certaines configurations d'entreprise ne permettent pas l'accès au contrôle DT Picker.
Pour remédier à cela, je vous propose de créer vous même votre propre contrôle calendrier, en utilisant un Userform.
Nota : Une nouvelle version de ce calendrier est disponible en téléchargement (version 4.xx). Elle permet de s'affranchir de deux des trois modules, en n'utilisant qu'un unique module de Classe.
Pour cette version, vous pouvez consulter cette fiche pratique.
L'UserForm
Celui-ci devra comporter entre 29 et 31 boutons de commande "Jours" et 4 boutons de commande (">>", ">", "<<" et "<") permettant le changement d'année et/ou de mois. Le mois et l'année "en cours" seront quand à eux, affichés dans le "Caption" (titre) de l'userform. Tous les contrôles, à l'intérieur de cet UserForm, seront créés dynamiquement. Vous n'aurez donc pas à les dessiner. De même, la taille importe peu car elle sera fonction du nombre de boutons et de leur disposition dans l'UserForm Calendrier.
Sous votre Editeur VBA, créez un nouvel Userform, et changez sa propriété Name en "Calendrier".
Dans le Module de cet UserForm, placez le code suivant :
Option Explicit
Private Sub UserForm_Initialize()
Dim Obj As Control
Dim i As Integer, Mois As Integer, Annee As Integer
Dim Cl As ClasseBtnChange
'Création Boutons Changement de mois et d'année
Set Collect = New Collection
'BOUTONS :
'- < et > = mois
'- >> et << = année
Set Obj = Me.Controls.Add("forms.CommandButton.1")
With Obj
.Name = "AnneePrec"
.Object.Caption = "<<"
.Left = 27
.Top = 1
.Width = 20
.Height = 20
End With
Set Cl = New ClasseBtnChange
Set Cl.Bouton = Obj
Collect.Add Cl
Set Obj = Me.Controls.Add("forms.CommandButton.1")
With Obj
.Name = "MoisPrec"
.Object.Caption = "<"
.Left = 50
.Top = 1
.Width = 20
.Height = 20
End With
Set Cl = New ClasseBtnChange
Set Cl.Bouton = Obj
Collect.Add Cl
Set Obj = Me.Controls.Add("forms.CommandButton.1")
With Obj
.Name = "MoisSuiv"
.Object.Caption = ">"
.Left = 75
.Top = 1
.Width = 20
.Height = 20
End With
Set Cl = New ClasseBtnChange
Set Cl.Bouton = Obj
Collect.Add Cl
Set Obj = Me.Controls.Add("forms.CommandButton.1")
With Obj
.Name = "AnneeSuiv"
.Object.Caption = ">>"
.Left = 98
.Top = 1
.Width = 20
.Height = 20
End With
Set Cl = New ClasseBtnChange
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
Set Cl = Nothing
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Set CollecBtnJours = Nothing
Set Collect = Nothing
End Sub
La procédure de création des boutons
Comme nous ne connaissons pas, à la base, le nombre de boutons "Jours" à créer, nous allons les créer dynamiquement. Pour cela, il nous faut une procédure qui :
- supprime les anciens boutons,
- créée les nouveaux en fonction du mois et de l'année.
Créez un Module (menu Insertion/Module) et placez y ce code :
Option Explicit
Public Collect As Collection, CollecBtnJours As Collection
Public MoisEnCours As Integer, AnneeEnCours As Integer
'Procédure de création des boutons Jours
'en fonction de l'année et du mois "en cours"
Sub CreationBoutonsJours(Mois As Integer, Annee As Integer)
Dim Obj As Control
Dim Cls As ClasseBtnJours
Dim NbJours As Integer, T As Integer, Gauc As Integer, Coul As Long, i As Integer, Taille As Integer
'Suppression de tous les boutons de commande "Jours"
For Each Obj In Calendrier.Controls
If Left(Obj.Name, 6) = "Bouton" Then Calendrier.Controls.Remove Obj.Name
Next
'création des boutons jours en fonction de l'année et du mois "en cours"
Set CollecBtnJours = New Collection
NbJours = Day(DateSerial(Annee, Mois + 1, 1) - 1)
For i = 1 To NbJours
If i = 1 Then T = 35
Select Case UCase(Format(DateSerial(Annee, Mois, i), "dddd"))
Case "LUNDI"
Gauc = 0
If i <> 1 Then T = T + 20
Coul = 13037551
Case "MARDI"
Gauc = 20
Coul = 13037551
Case "MERCREDI"
Gauc = 40
Coul = 13037551
Case "JEUDI"
Gauc = 60
Coul = 13037551
Case "VENDREDI"
Gauc = 80
Coul = 13037551
Case "SAMEDI"
Gauc = 100
Coul = 3754751
Case "DIMANCHE"
Gauc = 120
Coul = 3754751
End Select
If EstJourFerie(DateSerial(Annee, Mois, i)) Or Paques(Annee) = DateSerial(Annee, Mois, i) Then Coul = 1627780
Set Obj = Calendrier.Controls.Add("forms.CommandButton.1")
With Obj
.Name = "Bouton" & i
.Object.Caption = i
.Left = Gauc
.Top = T
.Width = 20
.Height = 20
.Object.BackColor = Coul
End With
If i = NbJours Then Taille = Obj.Top + Obj.Height + 20
Set Cls = New ClasseBtnJours
Set Cls.Btn = Obj
CollecBtnJours.Add Cls
Next i
With Calendrier
.Caption = Format(DateSerial(AnneeEnCours, MoisEnCours, 1), "mmmm yyyy")
.Tag = MoisEnCours & "/" & AnneeEnCours
.Height = Taille
.Width = 145
End With
Set Cls = Nothing
End Sub
Les modules de classe
Nous aurons besoin de deux modules de classe pour que nos boutons de commande puissent "agir".
La classe des boutons suivants et précédents
Un module de classe (nommé : ClasseBtnChange) qui va gérer les boutons "<<", "<", ">" et ">>".
Option Explicit
Public WithEvents Bouton As MSForms.CommandButton
Private Sub Bouton_Click()
Select Case Bouton.Name
Case "AnneePrec"
AnneeEnCours = AnneeEnCours - 1
If AnneeEnCours = 1899 Then
MoisEnCours = 1
AnneeEnCours = 1900
MsgBox "Première année : 1900"
End If
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
Case "AnneeSuiv"
AnneeEnCours = AnneeEnCours + 1
End Select
CreationBoutonsJours MoisEnCours, AnneeEnCours
End Sub
Nota : On voit, dans ce code, que ne sont prévues les années qu'à partir de 1900. C'est un choix délibéré en fonction des calendriers gérés par Excel. Vous pouvez tout à fait le modifier à votre convenance. Attention toutefois aux changements de calendriers dans le passé...
La classe des boutons "Jours"
Un module de classe (nommé : ClasseBtnJours) qui va gérer les boutons numérotés des jours.
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
Les fonctions "Jours fériés"
Dans le Module standard créé précédemment, nous allons ajouter trois fonctions. Celles-ci nous permettront d'identifier les jours fériés. Deux ne sont pas de moi, les sources ont été citées dans le code.
Fonction qui retourne le jour férié en "String"
'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 = "Nouvel An": Exit Function
Case 501
QuelFerie = "Fête du travail": Exit Function
Case 508
QuelFerie = "Armistice 39-45": Exit Function
Case 714
QuelFerie = "Fête Nationale": Exit Function
Case 815
QuelFerie = "Assomption": Exit Function
Case 1101
QuelFerie = "Toussaint": Exit Function
Case 1111
QuelFerie = "Armistice 14-18": Exit Function
Case 1225
QuelFerie = "Noël": Exit Function
End Select
End Function
Fonction identifiant les jours fériés
'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
Fonction Dimanche de Pâques
'SOURCES :
'http://blog.developpez.com/philben/p11431/vba-access/calculer-la-date-de-paques
Public Function Paques(ByVal an As Integer) As Date
'Calcul de la date du dimanche de Pâques à partir de l'année 325
'Performance par million d'appel :
' - Entre 325 et 1582 et entre 1900 et 2099 => 1/4 de seconde
' - Année supérieure à 1582 hors 1900 - 2099 => 1/2 de seconde
'Philben - v1.0 - Free to use
Dim a As Integer, b As Integer, c As Integer, d As Integer, e As Integer, f As Integer
If an < 10000 Then 'Limite supérieure des dates sous Access (31 décembre 9999)
Select Case an
Case 1900 To 2099 'Algorithme de Carter
a = (204 - 11 * (an Mod 19)) Mod 30 + 22
Paques = DateSerial(an, 3, a + 6 + (a > 49) - (an + an \ 4 + a + (a > 49)) Mod 7)
Case Is > 1582 'Proposé en 1876 dans la revue Nature (dérivé de l'algorithme de Delambre)
a = an Mod 19: b = an \ 100: c = an Mod 100
d = (19 * a + b - b \ 4 - (b - (b + 8) \ 25 + 1) \ 3 + 15) Mod 30
e = (32 + 2 * (b Mod 4) + 2 * (c \ 4) - d - c Mod 4) Mod 7
f = d + e - 7 * ((a + 11 * d + 22 * e) \ 451) + 114
Paques = DateSerial(an, f \ 31, f Mod 31 + 1)
Case Is > 324 'Algorithme de Oudin pour les dates juliennes < 1583 décrit par Claus Tondering
a = (19 * (an Mod 19) + 15) Mod 30
Paques = DateSerial(an, 3, 28 + a - (an + an \ 4 + a) Mod 7)
End Select
End If
End Function
Paramétrage des couleurs
Il n'est pas utile de développer ici tous les codes permettant le choix des couleurs. Je ne vais donc parler que de des codes permettant des actions spécifiques, le reste étant réellement une petite "usine à gaz".
Vous pouvez dorénavant choisir vous même les couleurs de fond et de polices des différents contrôles du calendrier.
Ces paramètres de couleur sont sauvegardés à chaque clic sur le bouton "Valider".
Vous pouvez également choisir des couleurs ne faisant pas partie des couleurs supplémentaires que j'ai ajouté.
Pour cela, il suffit d'écrire le code Long de votre couleur dans le textbox, de choisir à quel endroit du calendrier vous souhaitez l'affecter (boutons d'option) et de valider. Attention toutefois, le code lié à ce TextBox n'est pas "blindé". En cas de mauvaise saisie, je ne garantis pas le résultat.
Pour accéder aux différents paramètres, clic droit soit sur le fond du calendrier, soit sur un des boutons de commande. Un clic sur "Fini" lorsque vous avez entré tous vos paramètres, redimensionne le calendrier.
Stocker une information
Pour stocker des informations pouvant servir ultérieurement, nous pouvons utiliser les cellules des feuilles Excel. Dans le cas de notre calendrier, il eut été dommage d'obliger l'utilisateur à créer une feuille dans son classeur dans le seul but de stocker 10 codes couleurs... Pour cela, j'ai choisit de stocker ces informations dans le gestionnaire des noms d'Excel.
Vous stockez au préalable vos paramètres "d'origine" dans le gestionnaire de Noms :
Nouveau nom
=> zone Nom vous mettez ce que bon vous semble, exemple : Couleur_Fond_UserForm
=> zone fait référence à : vous indiquez votre code couleur à "sauvegarder", exemple : =13037551
Pour appeler ce code couleur depuis votre code, il suffit de stocker le contenu de "RefersTo" dans une variable, comme ceci :
Dim Nom As Name
For Each Nom In ThisWorkbook.Names
Select Case Nom.Name
Case "Couleur_Fond_UserForm"
'Len(Nom.RefersTo) - 1) sert à enlever le signe "=" dans RefersTo
Coul_Fond_USF = CLng(Right(Nom.RefersTo, Len(Nom.RefersTo) - 1))
Case Else
End Select
Next Nom
Nota : je vous ai placé ici le code dans une boucle car vous aurez certainement plus d'un paramètre à stocker.
Pour le modifier, depuis votre code VBA, il conviendra d'utiliser la syntaxe :
ActiveWorkbook.Names("Couleur_Fond_UserForm").RefersTo = "=1659755"
ou par l'intermédiaire d'une variable :
Nb =1659755
ActiveWorkbook.Names("Couleur_Fond_UserForm").RefersTo = "=" & Nb & ""
Événement Click au bouton droit de la souris
L'événement Click des CommandButton ne laisse pas le choix du bouton sur lequel vous avez cliqué. Pour avoir ce choix, il convient donc d'utiliser un autre événement : _MouseDown (ou _MouseUp). En effet, ces événements comportent dans leurs paramètres une référence au bouton cliqué :
ByVal Button As Integer
. Les boutons de votre souris vont tous déclencher cet événement, mais vous pourrez faire le tri dans le code lui-même. En fait, le paramètre Button peut prendre 4 valeurs constantes : xlNoButton, xlPrimaryButton, xlSecondaryButton, ou xlMiddleButton.
Nota : xlNoButton est plus utile dans l'événement MouseMove.
Exemple :
Ouvrez un nouveau classeur, insérez un UserForm et dans cet UserForm, dessinez un CommandButton. Le code de ce bouton :
Private Sub CommandButton1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Button = XlMouseButton.xlSecondaryButton Then 'action si bouton droit enfoncé MsgBox "clic droit" ElseIf Button = XlMouseButton.xlPrimaryButton Then 'action si bouton gauche enfoncé MsgBox "clic gauche" '!!!uniquement valable pour Excel 2003 (et pas valable pour les versions ultérieures) 'ElseIf Button = XlMouseButton.xlMiddleButton Then 'action si bouton du milieu enfoncé 'MsgBox "clic milieu" End If End Sub
Paramétrage des couleurs version 2
Dans cette nouvelle version vous ne serez plus obligés de saisir tous les noms dans le gestionnaire des noms d'Excel. Si vous voulez importer le calendrier dans un de vos classeurs, il vous suffira de copier les deux UserForms, le module Module1 et le module de classe Classe1. Tout le reste est automatisé.
Suite à la judicieuse remarque d'Eriiic, le bouton correspondant à "aujourd'hui" est remarquable car écrit en gras.
Ces fonctionnalités sont disponibles uniquement dans la "troisième version" téléchargeable plus bas.
Fonction Paques simplifiée
Dans cette version, la fonction calculant le dimanche de Pâques a été simplifiée. La nouvelle fonction utilise une formule de calcul passée en VBA grâce à la méthode Evaluate. Cela nous donne donc une fonction personnalisée d'une seule ligne...
Public Function Paques(ByVal an As Integer) As Date
Paques = CDate(Evaluate("=DATE(" & an & ",3,29.56+0.979*MOD(204-11*MOD(" & an & ",19),30)- WEEKDAY(DATE(" & an & ",3,28.56+0.979*MOD(204-11*MOD(" & an & ",19),30))))"))
End Function
Mode d'emploi
Intégration de ce contrôle à votre classeur
- Ouvrez les deux classeurs, le votre et celui que vous aurez choisi, ici, dans les téléchargements,
- Tapez ALT+F11 pour basculer sous l'éditeur Visual Basic,
- Dans la fenêtre VBA-Project, vous voyez les noms des classeurs ouverts :
- Double-clic sur le classeur du calendrier,
- Glissez-déplacez tout le contenu de ce classeur vers le votre (UserForms (feuilles), Module et Module de classe)
Pour configurer correctement le calendrier, voyez les commentaires de la Private Sub BoutonsJours_MouseDown dans le Module de Classe.
Paramétrage des couleurs
Le mode d'emploi est dans le classeur de démo. Je vous en mets une copie d'écran ici :
Taille du calendrier et de ses boutons
Une fois le calendrier intégré dans votre classeur, lancez le une première fois. Si les dimensions par défaut ne vous conviennent pas, allez dans le gestionnaire des noms de votre classeur (version > 2007 : Formules/Gestionnaire de noms, sous les versions antérieures, je crois qu'il se trouve dans le menu Insertion).
Dans ce gestionnaire des noms, changez la valeur "fait référence à" du nom de classeur : "Large". Il est par défaut réglé à 20, mais vous pouvez l'augmenter à souhait. Attention toutefois à ne pas dépasser la taille de votre écran, 40 semble être suffisant.
Téléchargements
Voici le Classeur exemple Version 1, non paramétrable, au format .xls.
Vous trouverez ICI, la version 2 qui vous laisse le choix des couleurs. Son mode d'emploi est situé juste ICI.
La troisième version, paramétrable également, est téléchargeable ICI.
Le code source de la version 4.xx est disponible ICI.
Comme d'habitude, les forums de CCM (Bureautique/Excel et Programmation/VB-VBA) sont disponibles pour toutes questions complémentaires.
N'hésitez pas.
