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

[patricktoulon]

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

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'                            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

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

Les couleur peuvent être changée au niveau des constantes

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

 

[patricktoulon]

moi j'ai pas fait ça
j'ai fais

Sub createCalendar(obj As Object)
    Dim nX As Boolean, n, tbl, List As Object, mm, an, j, E&, L&, T&, I&, valeur
    Dim fond, btpm, shap As Shape
    Set actuobject = obj
    
    For Each n In ThisWorkbook.Names
        If n.Name = "calendarcolor" Then nX = True
    Next
    
    If Not nX Then ActiveWorkbook.Names.Add Name:="calendarcolor", RefersTo:="11711154|16777215|16711680|9075792|16777215|16777215|16711680|13434879|255|10092288|255|"
    
    tbl = Split(Replace(ThisWorkbook.Names("calendarcolor"), "=""", ""), "|")
    
    On Error Resume Next:
    Set obj = ActiveSheet.DrawingObjects(Application.Caller)
    valeur = DateValue(obj.Text)
    On Error GoTo 0
    
    If obj Is Nothing Then Set obj = ActiveCell: valeur = DateValue(obj.Text)

obj.Text fonctionne même pour les textboxs activeX quand ils sont designés par la collection DrawingObjects
obj devient un public actuobj valable partout dans le calendar dans le module
exemple;
Set obj = ActiveSheet.DrawingObjects("TextBox1)
msgbox obj.text
obj.text="@fanch55"

c'est tout simple
pas de select case rien du tout
mais je travaille sur l'enregistrement là

 

[patricktoulon]

@fanch55 version 5.0

Thèmes prédéfinis sont des themes qui sont prédéfinis dans le module
Thèmes enregistrés sont des themes que l'on a enregistré
tout en bas tu a un bouton ENREGISTRER LE THEME
Il est débloqué seulement si tu change au moins une couleur
quand tu clique dessus tu a un inputbox qui s'ouvre pour que tu tape un nom pour le theme que tu veux enregistrer
ca va donc enregistrer un Name avec pour nom"CalendarTheme_" et le nom que tu a tapé dans l'inputbox
tu le retrouvera dans le sous menu" theme enregistrés"

tu peux le modifier a souhait en retapant son nom dans l'inputbox quand tu enregistre
une fois enregistré le bouton enregistrer le thème est de nouveau bloqué il te faut modifier une couleur pour le re débloquer
j'ai mis les boutons en francais puisque tu y tiens
voila sans modifier mon concept de départ
maintenant que le mode d'enregistrement est possible ,il est possible que le sous menu thème prédéfinis disparaissent je sais pas encore

 

[fanch55]

Salut du jour Patrick

Il faudrait aussi mener une réflexion sur la protection de feuille lors de l'affichage du calendrier pour éviter d'entrer en édition sur un de ses éléments, ce qui va finir par être exaspérant .

Le classeur joint est une déclinaison du #88 proposant un traitement de cette protection ( donc sans thème )

 

[patricktoulon]

Bonjour @fanch55
il n'y a qu'une seule solution pour ça c'est ce que j'avais fait avant
mettre un calque dessus transparent
et au click calculer la position
après je vois pas comment on pourrait empêcher autrement la sélection d'une shapes sans qu'il y en au une au dessus transparente
ps :je peux enregistrer les thèmes maintenant
ou lancer une protection au lancement du calendrier en bloquant la sélection des object peut être
mais suis pas convaincu

 

[patricktoulon]

@fanch55 j'ai trouvé
V 6 il n'y a plus de thèmes prédéfinis mais des thèmes enregistrés sauf le basique qui lui reste au cas ou
on ne peut plus sélectionner les shapes du calendrier en mode édition
seule le click gauche fonctionne dans le calendrier
je te laisse découvrir comment j'ai fait

 

[fanch55]

@fanch55 j'ai trouvé
V 6 il n'y a plus de thèmes prédéfinis mais des thèmes enregistrés sauf le basique qui lui reste au cas ou
on ne peut plus sélectionner les shapes du calendrier en mode édition
seule le click gauche fonctionne dans le calendrier
je te laisse découvrir comment j'ai fait

Patrick, si la feuille est déjà protégée par un mot de passe, ta méthode ne fonctionnera pas ( c'est pour cela que j'affiche un Userform en demandant le mot de passe utilisateur pour faire le protect avec interface correctement) .
Sinon, il me semble qu'il était demandé de colorer quand on le peut la date du jour et la date de l'objet de référence ( en plus des fériés ).
Le code se plante si on le fait sur un activex Label .

 

[patricktoulon]

à bien y réflechir tu te creuse la t^te pour rien sur la possibilité de feuille déja protégée par mot de passe
car dans tout les cas il faut protégé(provisoirement la feuille pendant l'affichage) sauf que la protection elle est juste pour les drawingObjects
mais la protection déjà en place (mot de passe ou pas )pourrait être différentes en terme d'option dans la fenêtre de protection donc ..........

v 7 terminé
j'ai ajouté le jour de la date
le jour de la reference à l'object
l'enregistrement de nouveau thèmes (et bien sur leur réutilisation)
ca fait un beau menu quand même