patricktoulon

[CENTER][B]Episode 2[/B]
[COLOR=#b22222][SIZE=2][B]Un calendrier dynamique simple

[/B][/SIZE][/COLOR][/CENTER]
apres moulte versions dans la meme serie a savoir dans un userform dynamiquement créé voici le pseudo calendar
la encore je n'utilise pas de module classe tout est dans la fonction

[LIST=1][*]creation de l'userform[*]des bouton et listbox[*]ecriture du code[/LIST]

la aussi rien n'existe avant /rien n'existe apres autrement dit le fichier ne reste pas parasité par des modules classe ou userforms inutiles

[CODE=vba]Option Explicit
'**********************************************************************************************
' COLLECTION DE BOITES DE DIALOG PERSO *
' modele: calandrier dynamique *
' version 4.0 07/02/2017 sans module classe *
' author: patricktoulon sur DVP.com ;alias chamalin2@hotmail.com *
'**********************************************************************************************
Function calendrier()
Dim UsF, ObJ, i&, L&, Jo, J&, t&
Set UsF = ThisWorkbook.VBProject.VBComponents.Add(3)
With UsF
.Properties("Caption") = "choisir une date": .Properties("Width") = 130: .Properties("Height") = 150:
.Properties("Backcolor") = RGB(230, 230, 230)
Set ObJ = UsF.Designer.Controls.Add("Forms.ComBobox.1")
With ObJ: .Left = 5: .Top = 5: .Width = 60: .Height = 15: .Name = "mois": .ListRows = 12: End With
Set ObJ = UsF.Designer.Controls.Add("Forms.ComBobox.1")
With ObJ: .Left = 70: .Top = 5: .Width = 55: .Height = 15: .Name = "an": End With
Jo = Array(, "lun", "mar", "mer", "jeu", "ven", "sam", "dim")
L = -12:
For i = 1 To 7
L = L + 17
Set ObJ = UsF.Designer.Controls.Add("Forms.Label.1")
With ObJ: .Left = L: .Top = 22: .Width = 15: .Height = 13: .Name = "tj" & i: .BorderStyle = 0:
.Caption = UCase(Jo(i)): .BackColor = RGB(100, 100, 200): .ForeColor = vbWhite: .TextAlign = 2
End With
Next

L = -12: t = 37
For i = 0 To 41
L = L + 17: If L >= 119 Then L = 5: t = t + 15
Set ObJ = UsF.Designer.Controls.Add("Forms.Label.1")
With ObJ: .Left = L: .Top = t: .Width = 15: .Height = 13: .Name = "jour" & i + 1:
.BorderStyle = 1: .BackColor = RGB(150, 150, 150): .ForeColor = vbWhite: .TextAlign = 2
End With
Next
With .CodeModule
J = .countoflines
.insertlines J + 1, "public madate as variant"
J = .countoflines
.insertlines J + 1, "function nbjours ( A&,M&)" & vbCrLf & "nbjours = Day(DateSerial(A, M+1 , 0) )" & vbCrLf & "End Function"
J = .countoflines
.insertlines J + 1, "Private Sub UserForm_Activate()" & vbCrLf & "Dim i&" & vbCrLf & _
"With Me.an: .List = Evaluate(""ROW("" & 1 & "":"" & Year(Date) + 100 & "")""): .Value = Year(Date): End With" & vbCrLf & _
"With mois: For i = 1 To 12: .AddItem Format(""01/"" & i & ""/2018"", ""mmmm""): Next: .Value = Format(Date, ""mmmm""): End With" & vbCrLf & "End Sub"
J = .countoflines
.insertlines J + 1, "Private Sub grille(A, M&)" & vbCrLf & "Dim NBJ&, x&,i&" & vbCrLf & "NBJ = nbjours(Val(A), M)" & vbCrLf _
& "For i = 1 To 42: Me.Controls(""jour"" & i).Caption = """": Next" & vbCrLf _
& "x = Weekday(DateSerial(A, M, 1), vbUseSystemDayOfWeek) - 1" & vbCrLf _
& "For i = 1 To NBJ: With Me.Controls(""jour"" & i + x): .Caption = i: .BackColor = &H969696: .ForeColor = vbYellow: .TextAlign = 2: End With: Next" & vbCrLf _
& "With Me.Controls(""jour"" & Day(Date) + x): If M = Month(Date) And A = Year(Date) Then .BackColor = vbWhite: .ForeColor = vbRed" & vbCrLf & "End With" & vbCrLf & "End Sub"
J = .countoflines
.insertlines J + 1, "Private Sub mois_Change()" & vbCrLf & "grille val(an.Value), mois.ListIndex + 1" & vbCrLf & "End Sub"
J = .countoflines
.insertlines J + 1, "Private Sub an_Change()" & vbCrLf & "grille val(an.Value), mois.ListIndex + 1" & vbCrLf & "End Sub"
J = .countoflines
.insertlines J + 1, "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)" & vbCrLf _
& "If CloseMode = 0 Then Cancel = True: madate = False: Me.Hide" & vbCrLf & "End Sub"
J = .countoflines
For i = 1 To 42
J = .countoflines
.insertlines J + 1, "Private Sub jour" & i & "_Click()" & vbCrLf & " If jour" & i & ".Caption <> """" Then madate = DateSerial(an.Value, mois.ListIndex + 1, jour" & i & ".Caption): Me.Hide" & vbCrLf & "End Sub"
Next
End With
End With
VBA.UserForms.Add (UsF.Name)
With UserForms(UserForms.Count - 1)
.Show
calendrier = .madate
End With
ThisWorkbook.VBProject.VBComponents.Remove (UsF)
End Function[/CODE]
[B]pour tester[/B]
[CODE=vba]Sub test()
Dim madate As Variant
madate = calendrier
MsgBox madate
End Sub[/CODE]

ici aussi le projet doit etre approuvé
[B]Sécurité des macros>Paramètres des macros> cocher la case "Accès approuvé au modèle d'objet du projet VBA".[/B]