Un calendar pour tous ( control calendrier )

**patricktoulon** · 23/07/2016, 23h50

Bonsoir

pour les utilisateur office 64 bits les contrôles pour les calendriers ne fonctionnent pas

alors je vous en ai fait un en version beta mais fonctionnel a 100%

je créé tout les boutons en dynamique dans une petite classe

nous allons commencer par ajouter un tex box dans notre userform et oui je dit bien un tex box et de la taille dont vous voulez que le calendrier prenne

dans l'exemple que je fourni vous verrez que j'ai mémé poussé le vice en nommant ce textbox "calendar" la bonne blague ) vous l'appellerez comme bon vous semble puisque que c'est le 2 argument de la fonction

alors voila maintenant que l'on a mis notre textbox heu.. non!!!! calendar heu.....

dans le module userform on va mettre dans le activate ceci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
 
Dim cl As New calendrier
 
Private Sub UserForm_Activate()
cl.creation_calandrier Me, Me.calendar
End Sub

les deux argument sont des object (l'userform et le textbox )

afin qu'il puisse se comporter comme si il en était vraiment un je vais utiliser l'évènement change du textbox heu... calendar heu......

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Private Sub calendar_Change()
MsgBox calendar
End Sub

voila pour l'userform c'est fini

maintenant passons a la classe

voici le code
le principe est très simple
j'ajoute une frame au dimensions et place du textbox il sera donc caché
j'ajoute 2 combobox (mois et année )
et pour finir les 31 boutons possible pour 31 jour voir 28 ou 29 pour février le tout automatiquement bien sur

tout les contrôles sont proportionné par rapport a la frame donc quelque dimensions que se soit le calendrier sera entier le tout automatiquement bien sur

et pour finir on gère les évènement clik et move des( boutons / frame )

donc en voici le code de cette classe que l'on nommera j'te l' donne dans l'mille "calendrier" (non vraiment ils sont fous ces toulonnais )

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
 
Option Explicit
Public WithEvents JRS As MSForms.Label
Public WithEvents formm As UserForm
Public WithEvents frame As MSForms.frame
Public WithEvents calendart As MSForms.TextBox
Public WithEvents listeA As MSForms.ComboBox
Public WithEvents listeM As MSForms.ComboBox
Private jr(31) As New calendrier
Public usf As UserForm
Function NB_JOURS(mois, année)
    NB_JOURS = Day(DateSerial(année, mois + 1, 1) - 1)
End Function
Function creation_calandrier(uf, ctr)
    Dim fram As Object, listm As Object, lista As Object, i As Long, widthbout As Long, heightbout As Long, thetop As Long, leleft, bout As Object
    Set jr(0).formm = uf
    Set fram = uf.Add("Forms.Frame.1", "cal")
    fram.Move ctr.Left, ctr.Top, ctr.Width, ctr.Height
    fram.BackColor = RGB(80, 80, 80)
    '************************ Ajout de la combobox des mois ********************************
    Set listm = fram.Add("Forms.combobox.1", "listemois")
    With listm
        .ListRows = 12: .Font.Size = 8: .TextAlign = 1: .Move 0, 0, fram.Width / 4 * 2, 15
        For i = 1 To 12: .AddItem Format("01/0" & i & "/2016", "mmmm"): Next
        .ListIndex = Month(Date) - 1
    End With
    '*******************************************Ajout de la combobox année***************************************************
    Set lista = fram.Add("Forms.combobox.1", "listeAnnée")
    With lista
        .Move listm.Width, 0, fram.Width / 4 * 2, 15
        For i = 1 To 30: .AddItem 2000 + 1 * i: Next
        .ListIndex = 15
    End With
    '**********************************************************************************************************************
    widthbout = (fram.Width - 8) / 8
    heightbout = (fram.Height - 30 - 12) / 5
    thetop = 20
    leleft = 2
    For i = 1 To NB_JOURS(listm.ListIndex + 1, lista.Value)
        Set bout = fram.Add("Forms.Label.1", "jour" & i)
        Set jr(i).JRS = bout: Set jr(i).listeA = lista: Set jr(i).listeM = listm
        Set jr(i).formm = uf: Set jr(i).frame = fram
        Set jr(i).calendart = uf.Controls("calendar")
        With bout
            .Caption = i: .BorderStyle = 1: .BackStyle = 1: .BackColor = RGB(120, 120, 120): .BorderColor = RGB(150, 0, 180): .ForeColor = RGB(255, 255, 255)
            .TextAlign = 2: .FontSize = 6
            .Move leleft, thetop, widthbout, heightbout
            leleft = leleft + widthbout + fram.Width / 52
            If i = 7 Or i = 14 Or i = 21 Or i = 28 Then thetop = thetop + heightbout + fram.Height / 34: leleft = 2
        End With
    Next
End Function
Private Sub JRS_Click()
    calendart.Value = DateSerial(listeA.Value, listeM.ListIndex + 1, JRS)
End Sub
Private Sub JRS_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If JRS.BackColor = RGB(120, 120, 120) Then
        If frame.Tag <> "" Then frame.Controls(frame.Tag).BackColor = RGB(120, 120, 120)
 
        JRS.BackColor = RGB(200, 200, 10)
        JRS.Parent.Tag = JRS.Name
    End If
End Sub
Private Sub frame_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If frame.Tag <> "" Then
        frame.Controls(frame.Tag).BackColor = RGB(120, 120, 120)
        frame.Tag = ""
    End If
End Sub

voila la démo en image

Nom : demo2.gif
Affichages : 3603
Taille : 904,2 Ko

le fichier en pièce jointe

**casefayere** · 27/07/2016, 23h24

Bonsoir Patrick,
Bravo pour le boulot mais, après avoir fait un test, perso, j'ai un bug dans cette procédure

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Function creation_calendrier(uf, ctr)
.....
.....
.Move leleft, thetop, widthbout, heightbout

et je crois que ça vient de cette variable "heightbout" qui est à "-2" chez moi

**patricktoulon** · 27/07/2016, 23h32

Bonjour casefayere

je comprends pas il est impossible que heightbout soit negatif je vais faire des essais

**casefayere** · 27/07/2016, 23h36

et moi, je vais le refaire sur mon autre PC (un portable récent) et te dirais quoi

**goninph** · 22/01/2017, 10h35

Hello,

Je vois que vous parlez de calendrier, avec OFFICE365 le calendrier est génial, on peux tout afficher,les N° de semaine, un mois, 2 mois ........ jusqu'à 12 mois

Bon dimanche Philippe

Nom : 22-01-2017 12-31-23.png
Affichages : 2608
Taille : 16,0 Ko

**patricktoulon** · 22/01/2017, 11h43

Envoyé par goninph

Hello,

Je vois que vous parlez de calendrier, avec OFFICE365 le calendrier est génial, on peux tout afficher,les N° de semaine, un mois, 2 mois ........ jusqu'à 12 mois

Voir fichier joint

Bon dimanche Philippe

Bonjour philippe et merci pour intervention

on est dans les contribution vba EXCEL ici et non office 365 ton fichier ne m'est d'aucune utilité sachant pour sur que je n'ai pas ce contrôles

d'autant plus que dans cette contribution il est question de construire son propre calendrier dynamiquement je précise au cas ou il n'est nullement question d'utiliser un control calendrier quelconque

seulement avec des controls frames , label , combobox que toute version Excel possèdent pour qu'il soit compatible avec toute c'est quand même le but de cette contribution

et comme c'est une contribution dont je suis l'auteur et non une discussion je ne souhaite pas voir d'autre fichiers que les miens éventuellement si non les visiteurs vont pas savoir quoi prendre

donc je t'en serais gré si tu t l'enlevais

par contre si tu veux poster quelques captures d'écran pour voir et démontrer ce qu'il peut faire je ne suis pas contre a fin d'ajouter ou améliorer le mien

j'attends tes captures (images)

**patricktoulon** · 22/01/2017, 12h00

re
OK capture vu

ben en tte nous il est bien moche ce control l'idée de la semaine n'est pas mal en face de chaque ligne je prends je vais travailler dessus

pour supprimer ton fichier tu va a tableau de bord puis sur cette fenêtre a gauche tu descends a "piece jointes" ,tu click

dans cette fenêtre tu a toutes les pièces jointes que tu a donné avec le titre de la discussion dans la quelle tu l'a mis tu coche le petit carré a droite

puis tu descend a supprimer en bas de cette page a droite

**casefayere** · 27/07/2016, 23h45

avec mes excuses, en le faisant sur l'autre PC, j'ai compris qu'il fallait tirer plus le textbox, maintenant impeccable
encore bravo, j'espère ne pas t'avoir fait stresser

bonne nuit

**patricktoulon** · 28/07/2016, 00h19

oui je n'est pas prévu de limite minimale de taille mais bon si on veux que ce soit lisible il faut un minimum

en fait l'erreur est provoqué par les -30-12
si le txtbox ne fait au moins 43
je vais donc remplacer ca par un prorata

**patricktoulon** · 28/07/2016, 00h26

voila correction
pour le heightbout

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

heightbout = (fram.Height - fram.Height / 2.42) / 5

après une taille minimum sur le textbox pour une lisibilité est requise quand même

merci casefayere car c'était bien un problème de conception une belle erreur de ma part

2 points pour toi

**goninph** · 22/01/2017, 12h50

Re

Voilà c'est fait.

L'idée du format de la date est excellente.

Un mois affiché n'est pas suffisant, il faudrait affiché 3 mois au minimum, c'est mon avis d'utilisateur

Pour avoir trouvé et modifié des USF calendar, le calendrier Excel365 est pour moi et jusqu'à ce jour le seul qui répond à mes attentes, car

Dans le calendrier Excel :

- Les flèches gauche et droite sont très utile pour passer de 3 mois en 3 mois, ou de mois en mois, ou de ... en ... de mois

- Si tu cliques sur le nom du mois, une liste déroulante affiche les mois, comme sur le tien, idem pour les années

- La date entourée de rouge est aujourd'hui

- La date en blanc est la date que contient la cellule cliquée

- Si pas de date dans la cellule, le calendrier s'affiche avec la date du jour

A+Philippe

**patricktoulon** · 22/01/2017, 13h08

re
perso je préfère choisir directement le mois dans la combo
cliquer 4 fois sur la flèche pour atteindre décembre
ou afficher les 12 mois au calendrier

dans mon calendrier la date du jour est en vert ouvre le a janvier tu verra
il y a l'effet mouse over pour voir ou est vraiment la souris et quel jour est vraiment survolé quand on le fait petit c'est utile

tu a un drôle sens de la pratique toi

tout ce que je vais garder de ton calendrier c'est l'idée de la semaine le reste c'est a JETTER pour moi

merci pour tes retours

**casefayere** · 28/07/2016, 00h44

j'ai corrigé et gardé sous le coude, on ne sait jamais ! si tu autorises à le diffuser.....(en citant l'auteur, bien sur)

re bonne nuit

**patricktoulon** · 28/07/2016, 01h25

re oui y a pas de soucis distribue (en citant l'auteur et pourquoi pas le lien a fin d'avoir le plus de retours possible pour d'éventuelles améliorations
tiens j'ai corrigé plein de petite chose tout du moins j'ai mis au prorata plutôt qu'utiliser des nombre y compris pour les font size

en attendant la version 1.0 le voila tout corrigé

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
Option Explicit
Public WithEvents JRS As MSForms.Label
Public WithEvents formm As UserForm
Public WithEvents frame As MSForms.frame
Public WithEvents calendart As MSForms.TextBox
Public WithEvents listeA As MSForms.ComboBox
Public WithEvents listeM As MSForms.ComboBox
Private jr(31) As New calendrier
Public usf As UserForm
Function NB_JOURS(mois, année)
    NB_JOURS = Day(DateSerial(année, mois + 1, 1) - 1)
End Function
Function creation_calandrier(uf, ctr)
    Dim fram As Object, listm As Object, lista As Object, i As Long, widthbout As Long, heightbout As Long, thetop As Long, leleft, bout As Object
    Set jr(0).formm = uf
    Set fram = uf.Add("Forms.Frame.1", "cal")
    fram.Move ctr.Left, ctr.Top, ctr.Width, ctr.Height
    fram.BackColor = RGB(80, 80, 80)
    fram.BorderStyle = 1
    fram.BorderColor = vbBlue
    '************************ Ajout de la combobox des mois ********************************
    Set listm = fram.Add("Forms.combobox.1", "listemois")
    With listm
        .ListRows = 12: .Font.Size = 8: .TextAlign = 1: .Move 0, 0, fram.Width / 4 * 2, 15: .BackColor = RGB(50, 0, 125): .ForeColor = RGB(255, 255, 0)
        For i = 1 To 12: .AddItem Format("01/0" & i & "/2016", "mmmm"): Next
        '.ListIndex = Month(Date) - 1
    .Value = Format(Date, "mmmm"): .BorderStyle = 1
    End With
    '*******************************************Ajout de la combobox année***************************************************
    Set lista = fram.Add("Forms.combobox.1", "listeAnnée")
    With lista
        .Move listm.Width, 0, fram.Width / 4 * 2, 15: .BackColor = RGB(50, 0, 125): .ForeColor = RGB(255, 255, 0): .ListRows = 15
        For i = 1800 To Val(Year(Date)) + 50: .AddItem i: Next
        '.ListIndex = 15
    .Value = Year(Date)
    End With
    '**********************************************************************************************************************
    widthbout = (fram.Width - 8) / 7.87
    heightbout = ((fram.Height - 20) - (fram.Height / 11) - fram.Height / 8) / 5
    thetop = 20
    leleft = 2
    For i = 1 To NB_JOURS(listm.ListIndex + 1, lista.Value)
        Set bout = fram.Add("Forms.Label.1", "jour" & i)
        Set jr(i).JRS = bout: Set jr(i).listeA = lista: Set jr(i).listeM = listm
        Set jr(i).formm = uf: Set jr(i).frame = fram
        Set jr(i).calendart = uf.Controls("calendar")
        With bout
 
            .Caption = i: .BorderStyle = 1: .BackStyle = 1: .BackColor = RGB(120, 120, 120): .BorderColor = RGB(150, 0, 180): .ForeColor = RGB(255, 255, 255)
            .TextAlign = 2: .FontSize = Round(widthbout / (widthbout / 6))
            .Move leleft, thetop, widthbout, heightbout
            leleft = leleft + widthbout + fram.Width / 52
            If i = 7 Or i = 14 Or i = 21 Or i = 28 Then thetop = thetop + heightbout + fram.Height / 33: leleft = 2
         End With
    Next
End Function
Private Sub JRS_Click()
    calendart.Value = DateSerial(listeA.Value, listeM.ListIndex + 1, JRS)
End Sub
Private Sub JRS_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If JRS.BackColor = RGB(120, 120, 120) Then
        If frame.Tag <> "" Then frame.Controls(frame.Tag).BackColor = RGB(120, 120, 120)
 
        JRS.BackColor = RGB(200, 200, 10)
        JRS.Parent.Tag = JRS.Name
    End If
End Sub
Private Sub frame_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If frame.Tag <> "" Then
        frame.Controls(frame.Tag).BackColor = RGB(120, 120, 120)
        frame.Tag = ""
    End If
End Sub

ca va faire plaisir a ce qui ont un office 64 bits hein !!!!

**patricktoulon** · 28/07/2016, 08h47

allez nouveau!!!!
changement des boutons jour au grès des comboboxs

suppression des jours non valide
exemple février de 2016 =29 jours
suppression du 31 si mois en 30 jours

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
Option Explicit
Public WithEvents JRS As MSForms.Label
Public WithEvents formm As UserForm
Public WithEvents frame As MSForms.frame
Public WithEvents calendart As MSForms.TextBox
Public WithEvents listeA As MSForms.ComboBox
Public WithEvents listeM As MSForms.ComboBox
Private jr(31) As New calendrier
Public usf As UserForm
Function NB_JOURS(mois, année)
    NB_JOURS = Day(DateSerial(année, mois + 1, 1) - 1)
End Function
Function creation_calandrier(uf, ctr)
    Dim fram As Object, listm As Object, lista As Object, i As Long, widthbout As Long, heightbout As Long, thetop As Long, leleft, bout As Object
    Set jr(0).formm = uf
    Set fram = uf.Add("Forms.Frame.1", "cal")
    With fram: .Move ctr.Left, ctr.Top, ctr.Width, ctr.Height: .BackColor = RGB(80, 80, 80): .BorderStyle = 1: .BorderColor = vbBlue: End With
    '************************ Ajout de la combobox des mois ********************************
    Set listm = fram.Add("Forms.combobox.1", "listemois")
    With listm
        .ListRows = 12: .Font.Size = 8: .TextAlign = 1: .Move 0, 0, fram.Width / 4 * 2, 15: .BackColor = RGB(50, 0, 125): .ForeColor = RGB(255, 255, 0)
        For i = 1 To 12: .AddItem Format("01/0" & i & "/2016", "mmmm"): Next
        '.ListIndex = Month(Date) - 1
    .Value = Format(Date, "mmmm"): .BorderStyle = 1
    End With
    '*******************************************Ajout de la combobox année***************************************************
    Set lista = fram.Add("Forms.combobox.1", "listeAnnée")
    With lista
        .Move listm.Width, 0, fram.Width / 4 * 2, 15: .BackColor = RGB(50, 0, 125): .ForeColor = RGB(255, 255, 0): .ListRows = 15
        For i = 1800 To Val(Year(Date)) + 50: .AddItem i: Next
        '.ListIndex = 15
    .Value = Year(Date)
    End With
    '**********************************************************************************************************************
    widthbout = (fram.Width - 8) / 7.87
    heightbout = ((fram.Height - 20) - (fram.Height / 11) - fram.Height / 8) / 5
    thetop = 20
    leleft = 2
    For i = 1 To NB_JOURS(listm.ListIndex + 1, lista.Value)
        Set bout = fram.Add("Forms.Label.1", "jour" & i)
               Set jr(i).JRS = bout: Set jr(i).listeA = lista: Set jr(i).listeM = listm
        Set jr(i).formm = uf: Set jr(i).frame = fram
        Set jr(i).calendart = uf.Controls("calendar")
        Set jr(i).listeM = listm
 
        With bout
 
            .Caption = i: .BorderStyle = 1: .BackStyle = 1: .BackColor = RGB(120, 120, 120): .BorderColor = RGB(150, 0, 180): .ForeColor = RGB(255, 255, 255)
            .TextAlign = 2: .FontSize = Round(widthbout / (widthbout / 6))
            .Move leleft, thetop, widthbout, heightbout
            leleft = leleft + widthbout + fram.Width / 52
            If i = 7 Or i = 14 Or i = 21 Or i = 28 Then thetop = thetop + heightbout + fram.Height / 33: leleft = 2
         End With
    Next
End Function
Private Sub JRS_Click()
    calendart.Value = DateSerial(listeA.Value, listeM.ListIndex + 1, JRS)
End Sub
Private Sub JRS_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If JRS.BackColor = RGB(120, 120, 120) Then
        If frame.Tag <> "" Then frame.Controls(frame.Tag).BackColor = RGB(120, 120, 120)
 
        JRS.BackColor = RGB(200, 200, 10)
        JRS.Parent.Tag = JRS.Name
    End If
End Sub
Private Sub frame_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If frame.Tag <> "" Then
        frame.Controls(frame.Tag).BackColor = RGB(120, 120, 120)
        frame.Tag = ""
    End If
End Sub
Private Sub listeM_Change()
changebout
End Sub
Private Sub listeA_Change()
changebout
End Sub
Sub changebout()
'MsgBox NB_JOURS(formm.Controls("listemois").ListIndex + 1, formm.Controls("listeAnnée").Value)
Dim ctrl, i As Long
For Each ctrl In formm.Controls("cal").Controls
If ctrl.Name Like "*jour*" Then
i = i + 1: ctrl.Caption = ""
If i <= Val(NB_JOURS(formm.Controls("listemois").ListIndex + 1, formm.Controls("listeAnnée").Value)) Then ctrl.Caption = i
End If
Next
End Sub

Nom : demo2.gif
Affichages : 3565
Taille : 220,3 Ko

**patricktoulon** · 28/07/2016, 08h54

re
correction sur le clik du bouton vide

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
Option Explicit
Public WithEvents JRS As MSForms.Label
Public WithEvents formm As UserForm
Public WithEvents frame As MSForms.frame
Public WithEvents calendart As MSForms.TextBox
Public WithEvents listeA As MSForms.ComboBox
Public WithEvents listeM As MSForms.ComboBox
Private jr(31) As New calendrier
Public usf As UserForm
Function NB_JOURS(mois, année)
    NB_JOURS = Day(DateSerial(année, mois + 1, 1) - 1)
End Function
Function creation_calandrier(uf, ctr)
    Dim fram As Object, listm As Object, lista As Object, i As Long, widthbout As Long, heightbout As Long, thetop As Long, leleft, bout As Object
    Set jr(0).formm = uf
    Set fram = uf.Add("Forms.Frame.1", "cal")
    With fram: .Move ctr.Left, ctr.Top, ctr.Width, ctr.Height: .BackColor = RGB(80, 80, 80): .BorderStyle = 1: .BorderColor = vbBlue: End With
    '************************ Ajout de la combobox des mois ********************************
    Set listm = fram.Add("Forms.combobox.1", "listemois")
    With listm
        .ListRows = 12: .Font.Size = 8: .TextAlign = 1: .Move 0, 0, fram.Width / 4 * 2, 15: .BackColor = RGB(50, 0, 125): .ForeColor = RGB(255, 255, 0)
        For i = 1 To 12: .AddItem Format("01/0" & i & "/2016", "mmmm"): Next
        '.ListIndex = Month(Date) - 1
    .Value = Format(Date, "mmmm"): .BorderStyle = 1
    End With
    '*******************************************Ajout de la combobox année***************************************************
    Set lista = fram.Add("Forms.combobox.1", "listeAnnée")
    With lista
        .Move listm.Width, 0, fram.Width / 4 * 2, 15: .BackColor = RGB(50, 0, 125): .ForeColor = RGB(255, 255, 0): .ListRows = 15
        For i = 1800 To Val(Year(Date)) + 50: .AddItem i: Next
        '.ListIndex = 15
    .Value = Year(Date)
    End With
    '**********************************************************************************************************************
    widthbout = (fram.Width - 8) / 7.87
    heightbout = ((fram.Height - 20) - (fram.Height / 11) - fram.Height / 8) / 5
    thetop = 20
    leleft = 2
    For i = 1 To NB_JOURS(listm.ListIndex + 1, lista.Value)
        Set bout = fram.Add("Forms.Label.1", "jour" & i)
               Set jr(i).JRS = bout: Set jr(i).listeA = lista: Set jr(i).listeM = listm
        Set jr(i).formm = uf: Set jr(i).frame = fram
        Set jr(i).calendart = uf.Controls("calendar")
        Set jr(i).listeM = listm
 
        With bout
 
            .Caption = i: .BorderStyle = 1: .BackStyle = 1: .BackColor = RGB(120, 120, 120): .BorderColor = RGB(150, 0, 180): .ForeColor = RGB(255, 255, 255)
            .TextAlign = 2: .FontSize = Round(widthbout / (widthbout / 6))
            .Move leleft, thetop, widthbout, heightbout
            leleft = leleft + widthbout + fram.Width / 52
            If i = 7 Or i = 14 Or i = 21 Or i = 28 Then thetop = thetop + heightbout + fram.Height / 33: leleft = 2
         End With
    Next
End Function
Private Sub JRS_Click()
    If JRS.Caption = "" Then Exit Sub
    calendart.Value = DateSerial(listeA.Value, listeM.ListIndex + 1, JRS)
End Sub
Private Sub JRS_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If JRS.BackColor = RGB(120, 120, 120) Then
        If frame.Tag <> "" Then frame.Controls(frame.Tag).BackColor = RGB(120, 120, 120)
 
        JRS.BackColor = RGB(200, 200, 10)
        JRS.Parent.Tag = JRS.Name
    End If
End Sub
Private Sub frame_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If frame.Tag <> "" Then
        frame.Controls(frame.Tag).BackColor = RGB(120, 120, 120)
        frame.Tag = ""
    End If
End Sub
Private Sub listeM_Change()
changebout
End Sub
Private Sub listeA_Change()
changebout
End Sub
Sub changebout()
'MsgBox NB_JOURS(formm.Controls("listemois").ListIndex + 1, formm.Controls("listeAnnée").Value)
Dim ctrl, i As Long
For Each ctrl In formm.Controls("cal").Controls
If ctrl.Name Like "*jour*" Then
i = i + 1: ctrl.Caption = ""
If i <= Val(NB_JOURS(formm.Controls("listemois").ListIndex + 1, formm.Controls("listeAnnée").Value)) Then ctrl.Caption = i
End If
Next
End Sub

**patricktoulon** · 29/07/2016, 17h04

Bonjour a tous

voila la version 2.0 (finale)

nouveauté:

ajout de la ligne d'entête colonne (noms des jours en abrégés)
placement des jours dans leur colonnes respectives
mise en évidence(en vert) du jour correspondant a la date du jour
effet mouse over revu et amélioré
ajout combo box du choix du format de sortie
design plus joli

apercu

Nom : demo2.gif
Affichages : 3487
Taille : 896,1 Ko

code de la classe :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
 
Option Explicit
Public WithEvents JRS As MSForms.Label
Public WithEvents formm As UserForm
Public WithEvents frame As MSForms.frame
Public WithEvents calendart As MSForms.TextBox
Public WithEvents listeA As MSForms.ComboBox
Public WithEvents listeM As MSForms.ComboBox
Public WithEvents listeF As MSForms.ComboBox
Private jr(42) As New calendrier
Function NB_JOURS(mois, année)
    NB_JOURS = Day(DateSerial(année, mois + 1, 1) - 1)
End Function
Function creation_calandrier(uf, ctr)
    Dim fram As Object, listm As Object, lista As Object, listf As Object, i As Long, Wbt As Long, HbT As Long, thetop As Long, leleft, bout, jourr, lig, col, formT
    jourr = Array("lun.", "mar.", "mer.", "jeu.", "ven.", "sam.", "dim.")
    formT = Array("FORMAT", "dd/mm/yyyy", "yyyy/mm/dd", "ddd dd mmm yyyy", "dddd dd mmmm yyyy")
    Set fram = uf.Add("Forms.Frame.1", "cal")
    With fram: .Move ctr.Left, ctr.Top, ctr.Width, ctr.Height: .BackColor = RGB(80, 80, 80): .BorderStyle = 1: .BorderColor = vbBlue: End With
    '************************ Ajout de la combobox des mois ********************************
    Set listm = fram.Add("Forms.combobox.1", "listemois")
    With listm
        .ListRows = 12: .Font.Size = 9: .TextAlign = 1: .Move 0, 0, fram.Width / 3, 15: .BackColor = RGB(150, 150, 150): .ForeColor = RGB(0, 0, 0)
        For i = 1 To 12: .AddItem Format("01/0" & i & "/2016", "mmmm"): Next
        .Value = Format(Date, "mmmm"): .BorderStyle = 1
    End With
    '*******************************************Ajout de la combobox année***************************************************
    Set lista = fram.Add("Forms.combobox.1", "listeAnnée")
    With lista
        .ListRows = 15: .Font.Size = 9: .TextAlign = 1: .Move listm.Width, 0, (fram.Width / 3), 15: .BackColor = RGB(150, 150, 150): .ForeColor = RGB(0, 0, 0):
        For i = 1800 To Val(Year(Date)) + 50: .AddItem i: Next
        .Value = Year(Date): .BorderStyle = 1
    End With
    '*******************************************Ajout de la combobox choix du format de sortie de la date ***************************************************
    Set listf = fram.Add("Forms.combobox.1", "listeFormat")
    With listf
        .ListRows = 15: .Font.Size = 9: .TextAlign = 1: .Move (fram.Width / 3) * 2, 0, (fram.Width / 3), 15: .BackColor = RGB(150, 150, 150): .ForeColor = RGB(0, 0, 0):
        .List = formT
        .ListIndex = 0
    End With
    '**********************************************************************************************************************
    ' dimention aux proportions
    Wbt = (fram.Width) / 7: HbT = (fram.Height - 41) / 6
    thetop = 20: leleft = 1
    For i = 0 To UBound(jourr)    ' ajout de la ligne d'entetes  pour les jours en lettre
        Set bout = fram.Add("Forms.lABEL.1", jourr(i))
        With bout
            .Caption = jourr(i): .Tag = i + 1: .BorderStyle = 1: .BackStyle = 1: .BackColor = RGB(70, 70, 70): .BorderColor = RGB(0, 200, 255): .ForeColor = RGB(255, 255, 255)
            .TextAlign = 2: .FontSize = Round(HbT / 2): .FontSize = IIf(.FontSize < 7, 7, .FontSize)
            .Move leleft + (Wbt * i) - 1 * i, thetop, Wbt, Round(fram.Height / 8)
        End With
    Next
    leleft = 1
    thetop = fram.Controls("lun.").Top + fram.Controls("lun.").Height + 2
    i = 0
    For lig = 1 To 6
        For col = 0 To 6
            i = i + 1
            Set bout = fram.Add("Forms.Label.1", "jour" & i)
            With bout
                .BorderStyle = 1: .BackStyle = 1: .BackColor = RGB(120, 120, 120): .BorderColor = RGB(255, 255, 255): .ForeColor = RGB(255, 255, 255)
                .TextAlign = 2: .FontSize = Round(HbT / 2)
                .FontSize = IIf(.FontSize < 7, 7, .FontSize)
                .Move leleft + (Wbt * col) - 1 * col, thetop, Wbt, Round(fram.Height / 8)
                'ajout des liste,frame,userform,textbox dans l'instance(i) de la classe calendrier du label
                With jr(i): Set .JRS = bout: Set .listeA = lista: Set .listeM = listm: Set .listeF = listf: Set .formm = uf: Set .frame = fram: Set .calendart = uf.Controls("calendar"): End With
            End With
            If col = 6 Or col = 14 Or col = 21 Or col = 28 Or col = 35 Or col = 42 Then thetop = thetop + HbT: leleft = 1
        Next col
    Next lig
    fram.Height = fram.Controls("jour42").Top + fram.Controls("jour42").Height + 3
    mise_a_jour fram
End Function
Private Sub JRS_Click()
    If listeF.ListIndex < 1 Then listeF.ListIndex = 1
    If JRS.Caption = "" Then Exit Sub
    If JRS.ForeColor <> vbGreen Then JRS.ForeColor = RGB(255, 150, 0)
    calendart.Value = Format(DateSerial(listeA.Value, listeM.ListIndex + 1, JRS), listeF.Value)
End Sub
Private Sub JRS_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If JRS.BackColor = RGB(120, 120, 120) Then
        If frame.Tag <> "" Then
            frame.Controls(frame.Tag).BackColor = RGB(120, 120, 120): frame.Controls(frame.Tag).BorderColor = vbWhite
            If frame.Controls(frame.Tag).ForeColor <> vbGreen Then frame.Controls(frame.Tag).ForeColor = vbWhite
        End If
        If JRS.Caption <> "" Then JRS.BackColor = RGB(100, 100, 100): JRS.BorderColor = RGB(0, 200, 255)
        If JRS.ForeColor <> vbGreen Then JRS.ForeColor = RGB(255, 0, 100)
        JRS.Parent.Tag = JRS.Name
    End If
End Sub
Private Sub frame_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If frame.Tag <> "" Then
        frame.Controls(frame.Tag).BackColor = RGB(120, 120, 120): frame.Controls(frame.Tag).BorderColor = vbWhite
        If frame.Controls(frame.Tag).ForeColor <> vbGreen Then frame.Controls(frame.Tag).ForeColor = vbWhite
        frame.Tag = ""
    End If
End Sub
Private Sub listeM_Change()
    mise_a_jour listeM.Parent
End Sub
Private Sub listeA_Change()
    mise_a_jour listeM.Parent
End Sub
Sub mise_a_jour(fram)
    Dim ctrl, i As Long, jj, decal
    For i = 1 To 42: fram.Controls("jour" & i).Caption = "": Next
    decal = Val(fram.Controls(Format(DateSerial(fram.Controls("listeAnnée").Value, fram.Controls("listemois").ListIndex + 1, 1), "ddd")).Tag)
    For i = 1 To NB_JOURS(fram.Controls("listemois").ListIndex + 1, fram.Controls("listeAnnée").Value)
        fram.Controls("jour" & i + decal - 1) = i
        If DateSerial(fram.Controls("listeAnnée").Value, fram.Controls("listemois").ListIndex + 1, i) = Date Then fram.Controls("jour" & i + decal - 1).ForeColor = vbGreen Else fram.Controls("jour" & i + decal - 1).ForeColor = vbWhite
    Next
End Sub

et toujours dans le userform
calendar est toujours un textbox

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
 
 
Dim cl As New calendrier
Private Sub calendar_Change()
MsgBox calendar
End Sub
 
Private Sub UserForm_Activate()
cl.creation_calandrier Me, Me.calendar
End Sub

vous en pensez quoi de celui la !!

**casefayere** · 01/08/2016, 20h12

Re bonjour Patrick,

C'est dingue les coïncidences, je crée un Usf pour des amis qui viennent de reprendre une petite entreprise, je doute que je puisse intégrer un dtPiker sur leurs PC, et bien, j'en profite pour intégrer ton calendrier et, pour l'instant, tout roule comme sur des roulettes, merci encore, je pense que cette version continuera de me rendre service

Bonne soirée

**patricktoulon** · 01/08/2016, 23h37

re
bonsoir casefayere je viens de rentrer

oui tu a vu la dernière version ????
ben si elle est la c'est pour qu'elle serve au plus grand nombre j'en suis ravi
en tout ca moi j'ai remplacé tout mes calendars par celle la comme ca plus de soucis si je passe en 64 ou autre raison que se soit
tu a vu les dernieres nouveautés ?????? "placement relatif c'est bien ca non???