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
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
' '******************************** CREATION CONTROL CALENDRIER DYNAMIQUE************************************
' ' Auteur: Chamalin2@hotmail.fr alias patricktoulon sur developpez.com *
' ' exemplaire pour DVP.com *
' ' ---------------------- *
' ' date de creation : 23/07/2016 *
' ' derniere mise ajour: *
' ' 1 aout 2016 : ajout du placement relatif *
' ' 2 aout 2016 :ajout du tiptext en cas de petite taille du calendrier *
' ' licence: libre a condition de citer l'auteur *
' '**********************************************************************************************************
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, Optional large As Long = 140)
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
Dim lefto, ltop
jourr = Array("lun.", "mar.", "mer.", "jeu.", "ven.", "sam.", "dim.")
formT = Array("FORMAT", "dd/mm/yyyy", "dd-mm-yyyy", "d/m/yy", "yyyy/mm/dd", "yyyy-mm-dd", "ddd dd mmm yyyy", "dddd dd mmmm yyyy")
Set fram = uf.Add("Forms.Frame.1", "cal")
lefto = IIf(uf.Width - (ctr.Left) < large, uf.Width - large - 10, ctr.Left)
ltop = IIf(uf.Height - ctr.Top < large, uf.Height - large * 0.88, ctr.Top)
With fram: .Move lefto, ltop, large, large * 0.7: .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: .ListRows = UBound(formT)
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): .BorderStyle = 1
.List = formT
.ListIndex = 0
End With
'**********************************************************************************************************************
' dimention aux proportions
Wbt = fram.Width / ((fram.Width / (fram.Width / 3)) * 2.35): HbT = (fram.Height - 41) / 6
thetop = 20: leleft = fram.Width / (fram.Width / 3)
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 = (fram.Width / (fram.Width / 3))
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 = fram.Width / (fram.Width / 3)
Next col
Next lig
fram.Height = fram.Controls("jour42").Top + fram.Controls("jour42").Height + 3
mise_a_jour fram
fram.Visible = False
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)
frame.Visible = False
End Sub
Private Sub calendart_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'formm.Controls("cal").Visible = True
frame.Visible = True
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
fram.Controls("jour" & i + decal - 1).ControlTipText = Format(DateSerial(fram.Controls("listeAnnée").Value, fram.Controls("listemois").ListIndex + 1, i), "dddd dd mmmm yyyy")
Next
End Sub
Private Sub calendar_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Me.Controls("cal").Visible = True
End Sub
Private Sub formm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
formm.Controls("cal").Visible = False
End Sub |
Un calendar pour tous ( control calendrier )
: ça peut servir aux autres 
Répondre avec citation
Partager