Menu

VBA Excel [All versions] - Calendar Control

USFRBR
Ask a question

VBA Excel [All versions] - Calendar Control


Introduction

The calendar control of VBA has changed between Excel 2003 and Excel 2010. The older versions have a control named as "Calendar" and for the new versions it is called the "DT Picker"control. Compatibility issues may arise when you try to use:
  • workbooks with the Calendar control on the new versions of Excel
  • workbooks with DT Picker on the previous version of Excel.

Another concern lies in the version of Microsoft Office being used. Some corporate configurations do not allow access to the DT Picker control. To remedy this, I suggest that you create your own calendar control, using a Userform.

The UserForm

The UserForm will contain:
  • 29 and 31 command buttons for the "Days".
  • A label "Choice of the Month".
  • 2 buttons ("<" and ">" ) to navigate between the months.
  • The current month and year will be displayed in the "Caption" (title) of the UserForm.
  • All controls within this UserForm will be created dynamically.

Getting Started

Open your VBA editor, create a new UserForm and change its Name property to "Calendrier".
Copy the below code in the Module of the UserForm: 

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

Create the buttons

The number of days vary from one month to another, so we will create them dynamically. For this, a procedure that we need:
  • Remove the old buttons
  • Create new buttons based on the month and year.

Create a module (Insert > Module) and copy the below code: 
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

The Class Modules

We will need to create to class module for the command buttons to work.

To navigate between months:

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

The class module for the days

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

Managing public holidays

In the standard module created earlier, we will add three functions to identify holidays.

A function that returns the holiday as a 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 = "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

A function that identifies the public holidays

'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

Related

Featured