Créer un calendrier dynamiquement et insérer la date choisie dans la cellule active

[SilkyRoad]

Cette procédure est facilement intégrable à un évènement de la feuille de calcul ou à une barre d'outils personnelle: La date sélectionnée est automatiquement insérée dans la cellule active.
Vous devez disposer de l'ocx MSCOMCT2.ocx pour utiliser les contrôles MonthView et DataPicker.



Ce premier exemple utilise le contrôle Monthview:

Enlevez le commentaire sur cette ligne '.insertlines j + 3, " Unload Me"
pour que la fenêtre se referme automatiquement après l'insertion de la date.

Code :

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
Option Explicit
Dim Usf As Object
 
Sub LancementProcedure()
    Dim X As Object
    Dim NomMonthView As String
 
    NomMonthView = "MonthView1"
    'Lance la procédure de création du userform et du contrôle MonthView
    Set X = UserForm_Et_MonthView_Dynamique(NomMonthView)
 
    'Affichage userform
    X.Show
 
    'Suppression du userform après la fermeture
    ThisWorkbook.VBProject.VBComponents.Remove Usf
    Set Usf = Nothing
End Sub
 
 
Function UserForm_Et_MonthView_Dynamique(NomObjet As String) As Object
    Dim Obj As Object
    Dim j As Integer
    'Création UserForm
    Set Usf = ThisWorkbook.VBProject.VBComponents.Add(3)
    With Usf
        .Properties("Caption") = "Mon calendrier"
        .Properties("Width") = 135
        .Properties("Height") = 140
    End With
 
    'Création du contrôle MonthView
    Set Obj = Usf.Designer.Controls.Add("MSComCtl2.MonthView.2")
 
    With Obj
        .Left = 0: .Top = 0: .Width = 150: .Height = 140
        .Name = NomObjet
        .ForeColor = &HC000C0
        .TitleBackColor = &HC000C0
    End With
 
 
    'Ajout de la procédure évènementielle DateClick du contrôle MonthView
    With Usf.CodeModule
        j = .CountOfLines
        .insertlines j + 1, "Sub " & NomObjet & "_DateClick(ByVal DateClicked As Date)"
        'Insère la date dans la cellule active
        .insertlines j + 2, "   ActiveCell = DateClicked"
        'Option pour refermer l'userform après l'insertion de la date.
        '.insertlines j + 3, "   Unload Me"
        .insertlines j + 4, "End Sub"
    End With
 
    VBA.UserForms.Add (Usf.Name)
    Set UserForm_Et_MonthView_Dynamique = UserForms(UserForms.Count - 1)
 
End Function

Voici une deuxième procédure qui utilise le contrôle DataPicker:

Code :

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
Option Explicit
Dim Usf As Object
 
Sub LancementProcedure()
    Dim X As Object
    Dim NomdtPicker As String
 
    NomdtPicker = "DtPicker1"
    Set X = UserForm_Et_DataPicker_Dynamique(NomdtPicker)
 
    X.Show
 
    ThisWorkbook.VBProject.VBComponents.Remove Usf
    Set Usf = Nothing
End Sub
 
 
Function UserForm_Et_DataPicker_Dynamique(NomObjet As String) As Object
    Dim Obj As Object
    Dim j As Integer
    Set Usf = ThisWorkbook.VBProject.VBComponents.Add(3)
    With Usf
        .Properties("Caption") = "Mon calendrier"
        .Properties("Width") = 130
        .Properties("Height") = 40
    End With
 
    Set Obj = Usf.Designer.Controls.Add("MSComCtl2.DTPicker.2")
 
    With Obj
        .Left = 0: .Top = 0: .Width = 130: .Height = 20
        .Name = NomObjet
        .CalendarBackColor = &HFF00FF
    End With
 
    With Usf.CodeModule
        j = .CountOfLines
        .insertlines j + 1, "Sub " & NomObjet & "_Change()"
        .insertlines j + 2, "   ActiveCell.Value = Format(DateSerial(Year(" _
            & NomObjet & "), Month(" & NomObjet & "), Day(" _
            & NomObjet & ")), " & Chr(34) & "dd mmmm yyyy" & Chr(34) & ")"
        'Option pour refermer l'userform après l'insertion de la date.
        '.insertlines j + 3, "   Unload Me"
        .insertlines j + 4, "End Sub"
    End With
 
    VBA.UserForms.Add (Usf.Name)
    Set UserForm_Et_DataPicker_Dynamique = UserForms(UserForms.Count - 1)
 
End Function

[pilounet54]

c'est de la balle! impeccable comment tu veux que je trouve tous cela moi en te remerciant tres tres vivementà garder trés trés précieusement je pourrai te mettre 10000 points pour cela @+