Microsoft 365 datepicker dynamique intra userform ou dans feuille 2 versions(frame dynamique)(toute version d'excel )

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

patricktoulon

XLDnaute Barbatruc
Bonjour à tous
suite a ta demande en Mp @JCabral j'ai ressorti mes archives
j'ai du ré ouvrir pas mal de zip pour le retrouver 🤪 🤪
j'ai bien entendu fait un peu de restructuration du code en effet il datait un peu
alors voila mon module classe pour avoir un calendar dynamique dans un userform et non un userform calendar en mode responsif comme ma ressource du même nom

cette classe va créer de toute pièce l'interface du calendrier a l’intérieur du userform
il n'y a pas de librairie particulière à activer
un module classe nommé:Dynamic_Calendrier
VB:
'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'                            Interface calendrier dans frame dynamique pour Userform By patricktoulon
'' Copyright (C) 2025
'' auteur:Patrick Verne sur developpez.com
'' Date version:22/06/2013
'' Mise à jour:
'' remastering complet du code version 2025
'' publié sur exceldownloads

Option Explicit

Dim cl(1 To 42) As New Dynamic_Calendrier
Public Datepicker As Object
Public WithEvents cbm As msforms.ComboBox
Public WithEvents cba As msforms.ComboBox
Public WithEvents Bt As msforms.Label
Public u As Object
Public cla As Dynamic_Calendrier '
Public CallerControl As Object
'--------------------------------
'Changez les couleurs ici
Const BackgroundColor = &HDACCC9
'les combobox
Const comboBackColor = &H808080
Const comboFontColor = vbYellow
'les titres de jour
Const headerBackColor = vbBlue
Const headerfontColor = vbYellow
'les jour de la semaine
Const DayBackColor = vbWhite
Const DayfontColor = vbBlue
'les jour weekend
Const WeekendBackColor = vbYellow
Const WeekendfontColor = vbRed
'les jour weekend
Const fériéBackColor = vbGreen
Const fériéfontColor = vbRed
'--------------------------------

Public Sub InitCalendar(uf)
    'Plaque du calendrier(frame
    Dim f, cbmois, cbyear, I&, B, T, E
    Set f = uf.Controls.Add("forms.Frame.1", "Calendar", True)
    Set Datepicker = f
    With f
        .Width = 150
        .Height = 120
        .Top = 10
        .Caption = ""
        .BackColor = &HDACCC9
        'combobox des mois
        Set cbmois = f.Add("forms.ComboBox.1", "cbmois", True)
        With cbmois
            .List = Application.GetCustomListContents(3)
            .Height = 15
            .ListRows = 12
            .Width = 50
            .Font.Bold = True
            Set cbm = cbmois
            Set u = uf
            cbmois.BackColor = comboBackColor
            cbmois.ForeColor = comboFontColor
        End With
    
        'combobox des années
        Set cbyear = f.Add("forms.ComboBox.1", "cbyear", True)
        With cbyear
            .List = Evaluate("row(1900:2050)")
            .Height = 15
            .ListRows = 12
            .Left = 85
            .Width = 50
            .Font.Bold = True
            Set cba = cbyear
            cbyear.BackColor = comboBackColor
            cbyear.ForeColor = comboFontColor
            .MatchEntry = 0
        End With
    
        'header de calendrier(les jours de semaines
        Dim jours As Variant, j As Variant
        jours = Application.GetCustomListContents(1)
        For Each j In jours
            Debug.Print j
            I = I + 1
            Set B = f.Add("forms.label.1", Left(j, 3) & "_", True)
            With B
                .Caption = Left(j, 3)
                .Width = 20
                .BorderStyle = 1
                .Height = 12
                .Left = (.Width + 1) * (I - 1)
                .TextAlign = 2
                .Top = 20
                .BackColor = headerBackColor
                .ForeColor = headerfontColor
                .Font.Bold = True
            End With
        Next j
    
        'les 42 positions de jours possibles
        T = 34
        For I = 1 To 42
            E = E + 1
            Set B = f.Add("forms.label.1", "j" & I, True)
            With B
                .Caption = "-"
                .Width = 20
                .BorderStyle = 1
                .Height = 12
                .Left = (.Width + 1) * (E - 1)
                .Top = T
                If E = 7 Then E = 0: T = T + 14
                .TextAlign = 2
                Set cl(I).Bt = B: Set cl(I).cbm = cbmois: Set cl(I).cba = cbyear: Set cl(I).u = uf
                Set cl(I).cla = Me: Set cl(I).Datepicker = f
            End With
        Next
    End With
    f.Visible = False
End Sub

Private Sub Bt_Click()
    'MsgBox DateSerial(cba, cbm.ListIndex + 1, Bt.Caption)
    cla.CallerControl = DateSerial(cba, cbm.ListIndex + 1, Bt.Caption)
    Datepicker.Visible = False
 
End Sub

Private Sub cba_Change()
    If cbm.ListIndex = -1 Or cba.ListIndex = -1 Then Exit Sub
    reloadmonth
End Sub

Private Sub cbm_Change()
    If cbm.ListIndex = -1 Or cba.ListIndex = -1 Then Exit Sub
    reloadmonth
End Sub

Sub reloadmonth()
    Dim d As Date, fin, X&, I&, E&
    d = DateSerial(cba, cbm.ListIndex + 1, 1)
    fin = Day(DateSerial(cba.Value, cbm.ListIndex + 2, 0))
    X = Weekday(d, vbUseSystemDayOfWeek)
    For I = 1 To 42
        With u.Controls("j" & I)
            .Caption = "-"
            .BackStyle = 0
            .ForeColor = vbBlack
        End With
    Next
    For I = X To X + fin - 1
        E = E + 1
        With u.Controls("j" & I)
            .BackStyle = 1
            .Caption = Day(d + (E - 1))
        
            .BackColor = DayBackColor
            .ForeColor = DayfontColor
        
            If Weekday(d + (E - 1), 2) >= 6 Then
                .BackColor = WeekendBackColor
                .ForeColor = WeekendfontColor
            End If
        
            If férié(d + (E - 1)) Then
                .BackColor = fériéBackColor
                .ForeColor = fériéfontColor
            End If
        End With
    Next
End Sub
Public Sub ShowCalendar(ctrl As Object)
    With Datepicker
        .Visible = True
        .Left = ctrl.Left + ctrl.Width
        .Top = ctrl.Top
    End With
    If IsDate(ctrl.Value) Then
        Dim A&, M&
        A = Year(CDate(ctrl.Value))
        M = Month(CDate(ctrl.Value)) - 1
    Else
        A = Year(Date): M = Month(Date) - 2
    End If
    cba.Value = A: cbm.ListIndex = M:
    cba.ListIndex = A - 1900
    reloadmonth
    Set Me.CallerControl = ctrl
End Sub
Function férié(d As Date) As Boolean
    férié = False
    Dim tbl(1 To 12) As Date, I&
    tbl(1) = DateSerial(Year(d), 1, 1)
    tbl(2) = CDate(((Round(DateSerial(Year(d), 4, (234 - 11 * (Year(d) Mod 19)) Mod 30) / 7, 0) * 7) - 6))
    tbl(3) = tbl(2) + 39
    tbl(4) = tbl(2) + 50
    tbl(5) = DateSerial(Year(d), 5, 1)
    tbl(6) = DateSerial(Year(d), 5, 8)
    tbl(7) = DateSerial(Year(d), 11, 11)
    tbl(8) = DateSerial(Year(d), 12, 25)
     tbl(9) = tbl(2) + 1
 For I = 1 To UBound(tbl)
        If (d) = (tbl(I)) Then férié = True: Exit For
    Next
End Function

exemple d'utilisation dans un userform
Code:
Dim cls As New Dynamic_Calendrier

Private Sub UserForm_Initialize()
    cls.InitCalendar Me
End Sub

Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 2 Then
        cls.ShowCalendar TextBox1
    End If
End Sub



demo3.gif

Les couleur peuvent être changée au niveau des constantes
VB:
'--------------------------------
'Changez les couleurs ici
Const BackgroundColor = &HDACCC9
'les combobox
Const comboBackColor = &H808080
Const comboFontColor = vbYellow
'les titres de jour
Const headerBackColor = vbBlue
Const headerfontColor = vbYellow
'les jour de la semaine
Const DayBackColor = vbWhite
Const DayfontColor = vbBlue
'les jour weekend
Const WeekendBackColor = vbYellow
Const WeekendfontColor = vbRed
'les jour weekend
Const fériéBackColor = vbGreen
Const fériéfontColor = vbRed
'--------------------------------
voila par de fenêtre calendar en plus mais le calendar est à l'intérieur du userform dans un frame
Patrick

Edit comme la discussion est longue je met ici en premier post le 4 versions
  1. la version frame pour userform dans une classe
  2. la version v 2.0 simple construite totalement avec des shapes pour les feuilles excel uniquement
  3. la version v3.0 avec possibilité de changer les couleur dynamiquemen(avec réécriture des valeur dans le Enum du module)
  4. la version 4.0 avec possibilité de changer les couleurs dynamiquement( les couleurs sont memorisé cette fois ci dans un name )
(condition (sine qua none pour la v 3): activer l'accès approuvé au modèle d'object du projet vbadans les options excel
 

Pièces jointes

Dernière édition:
re
il; suffisait de changer cela
If Not IsDate(cel.Value) Then mm = "janvier": an = 2025 Else mm = MonthName(Month(cel.Value)): an = Year(cel.Value)

en ceci

If Not IsDate(cel.Value) Then mm = monthname(month(date): an = 2025 Else mm = MonthName(Month(cel.Value)): an = Year(cel.Value)

tel qu'il est conçu il est facile d'aller cher des modifs
 
re
il; suffisait de changer cela
If Not IsDate(cel.Value) Then mm = "janvier": an = 2025 Else mm = MonthName(Month(cel.Value)): an = Year(cel.Value)

en ceci

If Not IsDate(cel.Value) Then mm = monthname(month(date): an = 2025 Else mm = MonthName(Month(cel.Value)): an = Year(cel.Value)

tel qu'il est conçu il est facile d'aller cher des modifs
C'est ce que j'ai fait
VB:
    If Not IsDate(cel.Value) _
    Then mm = MonthName(Month(Date)): an = Year(Date): Jo = Day(Date) _
    Else mm = MonthName(Month(cel.Value)): an = Year(cel.Value): Jo = Day(cel.Value)
 
Bonjour @fanch55
encore une petite surprise
tu va devoir activer l'acces approuvé au modèle d'object du projet vba
une fois cela fait click un peu sur la petite bande en haut à droite du calendrier
1757238890127.png


bien sur à la fermeture du classeur il faut enregistrer sinon les changement seront perdus

pour info j'ai mis les 3 versions à télécharger dans le premier post
 

Pièces jointes

Dernière édition:
Bonjour @fanch55
encore une petite surprise
tu va devoir activer l'acces approuvé au modèle d'object du projet vba
une fois cela fait click un peu sur la petite bande en haut à droite du calendrier
Regarde la pièce jointe 1222111

bien sur à la fermeture du classeur il faut enregistrer sinon les changement seront perdus
C'est alléchant de pouvoir changer les couleurs ainsi, mais si on doit altérer le code vba par macro, cela risque de ne pas être permis partout ??? 🤔
 
@fanch55
v 4.0
c'est, le même avec un name
au premier create ,si le name n'existe pas il est créé avec les couleurs de base
apres tu fait pareil que l'autre
Ci-joint un classeur ( sans theme ) dans lequel on peut afficher un calendrier pour
- une cellule
- un activex
- un shape
- une autre cellule
Le calendrier peut avoir la taille que l'on désire en agissant sur un ratio, à la droite ou en dessous de l'objet de référence .
Et bien sur avec toutes les commodités apportées par Patrick ( mais sans les themes )
 

Pièces jointes

Bonjour @Fanch 55
les shapes et textboxs c'est bien
mais là tu t'éloigne de mon concept du menucolor
on ne peut plus ajouter des prédéfinis sans faire une usine a gaz
d'autant plus que j'étais sur la partie "Enregistrer le theme" là
j'ai ajouté sur le mien les shapes et textbox activX

si tu veux pas t'ennuyer avec le type n'utilise pas shape mais drawingobjects(application.caller)
DrawingObjects=collection d'object dessiné sur la feulles(shape , wordArt , textbox activX , etc...)
et donc c'est .text pour ces object donc date formatée
sinon range ben c'etait deja en place
et je garde mon sous menu "thèmes prédéfinis"

la 4.3 va sortir patiente un peu je teste les meilleures solution pour enregistrer le thème qui viens d'être créé
 

Pièces jointes

mais là tu t'éloigne de mon concept du menucolor


J'ai juste rajouté ce qui est dans le cadre orange et qui était demandé par les utilisateurs en tentant de rendre le menu plus clair
1757615298013.png
si tu veux pas t'ennuyer avec le type n'utilise pas shape mais drawingobjects
(application.caller)
DrawingObjects=collection d'object dessiné sur la feulles(shape , wordArt , textbox activX , etc...)
L'activex Label n'a pas de DrawingObject ni de propriété text ou value, lui c'est caption .
J'ai conservé tous les DrawingObjects partout où ils fonctionnent ( je les aime bien) et utilisé le typename uniquement en entrée et en sortie du calendar, puisque il y a des cellules et des labels
et donc c'est .text pour ces object donc date formatée
J'ai du rajouter Format car la date renvoyée inversait parfois les mois et jour ... sinon je m'en serais bien passé .
Enrichi (BBcode):
'le onAction pour les boutons
Sub PutDateTarget()
Dim Newdate As Date
    With ActiveSheet.DrawingObjects
        If .Item(Application.Caller).Text = "-" Then Exit Sub
        'inscription de la date constituée des trois données( bouton / cbx_Mois / Cbx_Ans)
        Newdate = DateValue(.Item(Application.Caller).Text & "/" & .Item("Cbx_Mois").Text & "/" & .Item("Cbx_Ans").Text)
        Select Case TypeName(RefObj)
        Case "Label":   RefObj.Caption = Newdate
        Case "Shape":   RefObj.DrawingObject.Text = Format(Newdate, "dd/mm/yyyy")
        Case Else:      RefObj.Value = Newdate
        End Select
    End With
    'suppression du calendrier
    Delete_Calendar
End Sub
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Retour