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
exemple d'utilisation dans un userform
Les couleur peuvent être changée au niveau des constantes
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
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 Functionexemple 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 SubLes 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
'--------------------------------Patrick
Edit comme la discussion est longue je met ici en premier post le 4 versions
- la version frame pour userform dans une classe
- la version v 2.0 simple construite totalement avec des shapes pour les feuilles excel uniquement
- la version v3.0 avec possibilité de changer les couleur dynamiquemen(avec réécriture des valeur dans le Enum du module)
- la version 4.0 avec possibilité de changer les couleurs dynamiquement( les couleurs sont memorisé cette fois ci dans un name )
Dernière édition:
