Voir le flux RSS

patricktoulon

Ma collection de boite de dialogue perso episode 2

Note : 4 votes pour une moyenne de 1,00.
par , 28/09/2018 à 17h13 (193 Affichages)
Episode 2
Un calendrier dynamique simple

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

  1. creation de l'userform
  2. des bouton et listbox
  3. ecriture du code


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 : 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
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
pour tester
Code vba : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
Sub test()
    Dim madate As Variant
    madate = calendrier
    MsgBox madate
End Sub

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

Envoyer le billet « Ma collection de boite de dialogue perso episode 2 » dans le blog Viadeo Envoyer le billet « Ma collection de boite de dialogue perso episode 2 » dans le blog Twitter Envoyer le billet « Ma collection de boite de dialogue perso episode 2 » dans le blog Google Envoyer le billet « Ma collection de boite de dialogue perso episode 2 » dans le blog Facebook Envoyer le billet « Ma collection de boite de dialogue perso episode 2 » dans le blog Digg Envoyer le billet « Ma collection de boite de dialogue perso episode 2 » dans le blog Delicious Envoyer le billet « Ma collection de boite de dialogue perso episode 2 » dans le blog MySpace Envoyer le billet « Ma collection de boite de dialogue perso episode 2 » dans le blog Yahoo

Mis à jour 10/11/2018 à 16h40 par LittleWhite (Coloration du code)

Catégories
Sans catégorie

Commentaires