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