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.