[VBA-E] Création de contrôle dynamique, la galère en moins

[spileo]

Bonsoir

Depuis un certain temps je m'intéresse à la création de contrôles dynamique. En effet, rien de plus pénible à mes yeux que de comprendre le cheminement d'un programme écrit par quelqu'un d'autre où se produisent des évènements en cascade alors que lire un code source peu s'avérer tellement plus clair. L'idée c'est donc de créer des contrôles dans un classeur de résultat mais sans les déclarer avec le traditionnel Public WithEvents tout en gérant des évènements dessus ce qui simplifie la programmation (Vous n'aurez qu'à essayer de piéger un évènement Exit sur un TextBox créé dynamiquement pour voir). Ce qui nous intéresse ici c'est la propriété "Designer" d'un objet qui fait référence à un Userform. Mais trève de blabla.

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
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
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
 
'Ajout des références
'Vers Microsoft Visual Basic for Applications Extensibility 5.3 pour manipuler les modules de code
'Vers Microsoft Forms 2.0 Object Library pour pouvoir créer des contrôles dynamiquement ("C:\WINDOWS\system32\FM20.DLL")
'Vers Microsoft Windows Common Controls (SP6) pour pouvoir créer une progressBar dynamiquement ("C:\WINDOWS\system32\MSCOMCTL.OCX")
Sub CreationEtatAvancement()
    Dim ClasseurRes As Workbook
    Dim ClasseurCode As Workbook
    Dim F As Object
    Dim C As Control
    Dim MH As Single
    Dim LF As Single
    Dim Y As Single
    Dim MG As Single
 
    Dim MC As CodeModule
    Dim Nbl As Long
    Dim Lcode As String
 
    Dim o As Object
 
    Set ClasseurCode = Application.ActiveWorkbook
    Set ClasseurRes = Workbooks.Add
 
    Set F = ClasseurRes.VBProject.VBComponents.Add(vbext_ct_MSForm)
    F.Name = "Progression"
 
    F.Properties("Height") = 300 + F.Properties("Height") - F.Designer.InsideHeight
    F.Properties("Width") = 300 + F.Properties("Width") - F.Designer.InsideWidth
 
    Set C = F.Designer.Controls.Add("Forms.Label.1", "LblTitre")
    MH = 10
    C.Top = MH
    C.Caption = " Progression "
    C.AutoSize = True
    C.WordWrap = False
    C.Font.Name = "Comic Sans MS"
    C.Font.Bold = False
    C.Font.Italic = True
    C.Font.Size = 12
    C.TextAlign = 2
    LF = F.Designer.InsideWidth
    C.Left = (LF - C.Width) / 2
    Y = C.Top + C.Height + 0.5 * MH
 
    Set C = F.Designer.Controls.Add("Forms.Label.1", "LblOp")
    C.Caption = "Opération en cours:"
    C.AutoSize = True
    C.WordWrap = False
    C.Top = Y
    MG = 10
    C.Left = MG
 
    Set C = F.Designer.Controls.Add("Forms.TextBox.1", "TxtD1")
    C.Width = 50
    C.WordWrap = False
    C.Top = Y
    C.Left = F.Designer.InsideWidth - C.Width - MG
    Y = C.Top + C.Height + 0.5 * MH
 
    Set C = F.Designer.Controls.Add("Forms.Label.1", "LblTCES")
    C.Caption = "Temps de calcul estimé:"
    C.AutoSize = True
    C.WordWrap = False
    C.Top = Y
    C.Left = MG
 
    Set C = F.Designer.Controls.Add("Forms.TextBox.1", "TxtD2")
    C.Width = 50
    C.WordWrap = False
    C.Top = Y
    C.Left = F.Designer.InsideWidth - C.Width - MG
    Y = C.Top + C.Height + 0.5 * MH
 
    F.Properties("Height") = Y + F.Properties("Height") - F.Designer.InsideHeight
 
 
 
    'Là ça coince:
    'Set C = F.Designer.Controls.Add("Forms.ProgressBar.1", "PgrProgression") '=> Marche pas "Chaîne de classe incorrecte"
    'Set C = F.Designer.Controls.Add("MSComctlLib.ProgressBar.1", "PgrProgression") '=> Marche pas "Chaîne de classe incorrecte"
    'Set C = F.Designer.Controls.Add("ComctlLib.ProgressBar.1", "PgrProgression") '=> Marche pas "Chaîne de classe incorrecte"
    'Set o = F.Designer.Controls.Add("Forms.ProgressBar.1", "PgrProgression") '=> Marche pas "Chaîne de classe incorrecte"
    'Set o = F.Designer.Controls.Add("MSComctlLib.ProgressBar.1", "PgrProgression") '=> Marche pas "Chaîne de classe incorrecte"
    'Set o = F.Designer.Controls.Add("ComctlLib.ProgressBar.1", "PgrProgression") '=> Marche pas "Chaîne de classe incorrecte"
    F.Properties("Height") = Y + F.Properties("Height") - F.Designer.InsideHeight
 
    Set MC = F.CodeModule
 
    With MC
 
        Nbl = .CountOfLines
        Lcode = "Option Explicit"
        .InsertLines Nbl + 1, Lcode
 
        Nbl = .CountOfLines
        Lcode = "Private Sub TxtD1_Enter()"
        .InsertLines Nbl + 1, Lcode
 
        Nbl = .CountOfLines
        Lcode = Chr(9) & "TxtD1.Text = ""Entrée"""
        .InsertLines Nbl + 1, Lcode
 
        Nbl = .CountOfLines
        Lcode = Chr(9) & "TxtD2.Text = """""
        .InsertLines Nbl + 1, Lcode
 
        Nbl = .CountOfLines
        Lcode = "End Sub"
        .InsertLines Nbl + 1, Lcode
 
        Nbl = .CountOfLines
        Lcode = "Private Sub TxtD1_Exit(ByVal Cancel As MSForms.ReturnBoolean)"
        .InsertLines Nbl + 1, Lcode
 
        Nbl = .CountOfLines
        Lcode = Chr(9) & "TxtD2.Text = ""Sortie"""
        .InsertLines Nbl + 1, Lcode
 
        Nbl = .CountOfLines
        Lcode = Chr(9) & "TxtD1.Text = """""
        .InsertLines Nbl + 1, Lcode
 
        Nbl = .CountOfLines
        Lcode = "End Sub"
        .InsertLines Nbl + 1, Lcode
    End With
 
    Set MC = ClasseurRes.VBProject.VBComponents.Add(vbext_ct_StdModule).CodeModule
    With MC
 
         Nbl = .CountOfLines
        Lcode = "Option Explicit"
        .InsertLines Nbl + 1, Lcode
 
        Nbl = .CountOfLines
        Lcode = "Private Sub Test()"
        .InsertLines Nbl + 1, Lcode
 
        Nbl = .CountOfLines
        Lcode = Chr(9) & "Load Progression"
        .InsertLines Nbl + 1, Lcode
 
        Nbl = .CountOfLines
        Lcode = Chr(9) & "Progression.Show"
        .InsertLines Nbl + 1, Lcode
 
        Nbl = .CountOfLines
        Lcode = "End Sub"
        .InsertLines Nbl + 1, Lcode
 
    End With
 
    DoEvents
 
    Application.Run ClasseurRes.Name & "!Test"
 
End Sub

Voilà. J'espère que ça intéressera du monde. Si quelqu'un a une idée pour la progressbar je suis preneur.

A+.

[ouskel'n'or]

Juste pour t'embêter
Tu peux raccourcir ton code en créant un tableau des lignes à insérer dans ton code (30 lignes au lieu de 60 ~)

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
Dim Lcode(14)
        Lcode(1)= "Option Explicit"
        Lcode(2) = "Private Sub TxtD1_Enter()"
        Lcode(3) = Chr(9) & "TxtD1.Text = ""Entrée"""
        Lcode(4) = Chr(9) & "TxtD2.Text = """""
        Lcode(5) = "End Sub"
        Lcode(6) = "Private Sub TxtD1_Exit(ByVal Cancel As MSForms.ReturnBoolean)"
        Lcode(7) = Chr(9) & "TxtD2.Text = ""Sortie"""
        Lcode(8) = Chr(9) & "TxtD1.Text = """""
        Lcode(9) = "End Sub"
        Lcode(10) = "Option Explicit"
        Lcode(11) = "Private Sub Test()"
        Lcode(12) = Chr(9) & "Load Progression"
        Lcode(13) = Chr(9) & "Progression.Show"
        Lcode(14) = "End Sub"
    With MC ‘ 1 à 9
        For i = 1 to 9
             Gosub Ecrire
        Next
    End With
    Set MC = ClasseurRes.VBProject.VBComponents.Add(vbext_ct_StdModule).CodeModule
    With MC ’10 à 14
         For i = 10 to 14
             Gosub Ecrire
         Next
    End With
    Exit sub
Ecrire::
    Nbl = .CountOfLines
    .InsertLines Nbl + 1, Lcode(i)
Return
End sub

Pas testé...
Ainsi, plus tu as de code, plus tu te rapproches d'un rapport de 1/3 quant au nombre de lignes de code et plus tu facilites la lecture du code inséré
Juste une idée et pour dire quelque chose

[tirex28]

Bonjour,

Voilà. J'espère que ça intéressera du monde

J'en suis sur.

Deux petits bugs:

Code :

Lcode = "Option Explicit"

Si on utilise cette option par défaut, on la retrouve deux fois dans chaque module, VBA se fache.

Code :

1
2
3
Lcode = "Private Sub Test()"
'+
Application.Run ClasseurRes.Name & "!Test"

Avec Public ca devrait mieux passer.

Beau travail,

Tirex28/

[spileo]

Bonsoir,
tirex28:

Si on utilise cette option par défaut, on la retrouve deux fois dans chaque module, VBA se fache

Exact j'y avais jamais fait attention vu que ça ne se produit qu'à l'ajout d'un vbcomponent dans le projet vba cible. C'est un peu bête d'ailleurs: tout est fait pour qu'on puisse écrire du code de manière dynamique et là on se retrouve avec une option qu'on ne peut pas, à mon humble connaissance, désactiver à moins de misérer avec du SendKeys (je vais quand même faire une petite recherche)

Avec Public ca devrait mieux passer

Là j'ai pas bien compris ce dont tu parlais.

ouskel'n'or:
C'est vrai que je suis pas un pro de l'optimisation d'écriture de code dynamique. Un truc que j'ai mis au point et qui fonctionne en vue d'exporter du code:

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
 
Sub AC_ExportProgression()
    Dim MC As VBComponent
    Dim CM As CodeModule
    Dim iLD As Long
    Dim iL As Long
    Dim LCode As String
 
    Set CM = ClasseurCode.VBProject.VBComponents("AA_DemarrageLogiciel").CodeModule
    Set MC = ClasseurRes.VBProject.VBComponents.Add(vbext_ct_StdModule)
    MC.Name = "MCProgression"
 
'Debut Export Code Progression
'Public Declare Function GetTickCount Lib "kernel32" () As Long
'Option Explicit
'Sub ChargementProgression()
''   Load Progression
'End Sub
'Sub AffichageProgression(Op As String, TCES As Long, TCEC As Long, TCR As Long)
'   If Progression.Visible = False Then Progression.Show vbModeless
'   Progression.LblOp.Caption = "Opération en cours: " & Op
'   Progression.LblTCES.Caption = "Temps de calcul estimé:" & BR_Temps(TCES)
'   Progression.LblTCEC.Caption = "Temps de calcul écoulé:" & BR_Temps(TCEC)
'   Progression.LblTCR.Caption = "Temps de calcul restant:" & BR_Temps(TCR)
'   Progression.Repaint
'End Sub
'Sub MasquageProgression()
'   Progression.Hide
'End Sub
'Fin Export Code Progression
 
    If CM.Find("'Debut Export Code Progression", iLD, 1, -1, -1) Then
        iLD = iLD + 1
        With MC.CodeModule
 
            Do
                LCode = Mid(CM.Lines(iL + iLD, 1), 2)
                If LCode = "Fin Export Code Progression" Then Exit Do
                'Debug.Print LCode
                .InsertLines .CountOfLines + 1, LCode
                iL = iL + 1
            Loop
        End With
    End If
End Sub

Je sais c'est pas très joli, le seul avantage de cette méthode c'est qu'elle permet de voir un peu mieux ce que tu exportes (gare au caractère _).

Merci de vos conseils éclairés. A+

[spileo]

Désactivation de l'option "Option Explicit". Fonctionne même si l'application est cachée. Nécessite de déclarer l'api "Sleep"

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
 
Sub AE_VerifOptionsVBE()
    Dim MC As VBComponent
    Dim Nbl As Long
    Dim W As vbide.Window
    Dim Vsble As Boolean
 
    If ClasseurCode.VBProject.VBE.MainWindow.Visible = True Then
        Vsble = True
    Else
        Vsble = False
    End If
 
    Set MC = ClasseurRes.VBProject.VBComponents.Add(vbext_ct_StdModule)
    Nbl = MC.CodeModule.CountOfLines
    If Nbl = 2 Then
        DoEvents
        Sleep 100
        DoEvents
        ClasseurCode.VBProject.VBE.MainWindow.Visible = True
        ClasseurCode.VBProject.VBE.MainWindow.SetFocus
        Application.SendKeys Keys:="%oo{TAB} ~", Wait:=True
        DoEvents
        Sleep 100
        DoEvents
    End If
 
    ClasseurRes.VBProject.VBComponents.Remove MC
 
    If Vsble = True Then
        ClasseurCode.VBProject.VBE.MainWindow.Visible = True
    ElseIf Vsble = False Then
        ClasseurCode.VBProject.VBE.MainWindow.Visible = False
    End If
 
End Sub

Bonne soirée.

[tirex28]

Bonsoir,

Là j'ai pas bien compris ce dont tu parlais.

Code :

1
2
3
Lcode = "Private Sub Test()"
'+
Application.Run ClasseurRes.Name & "!Test"

La procédure Test étant privée on ne peut y accéder depuis un autre classeur, Application.Run provoque donc une erreur "Impossible de trouver la macro..etc"

Plus de soucis avec:

Code :

Lcode = "Public Sub Test()"

Concernant Option Explicit, plutot que d'employer SendKeys et des API, il me semble plus simple de ne pas écrire cette instruction, ca fonctionnera quelque soit la configuration du poste. Sinon regarde la propriété CountOfDeclarationLines de l'objet CodeModule, ca devrait t'aider à mettre en oeuvre une solution plus 'propre'.

Tant que j'y suis, une petite question: Pourquoi créer le formulaire dans un nouveau classeur et pas dans celui qui contient la macro?


Cordialement,

Tirex28/

[spileo]

Bonsoir,

Pourquoi créer le formulaire dans un nouveau classeur et pas dans celui qui contient la macro?

Je fais ça pour plusieurs raisons plus ou moins valables:

-la première c'est que je suis un peu parano et que je me dis que si je crée le formulaire dans le même classeur que celui qui contient la macro, si jamais y'a une coupure de courant et qu'elle survient au moment où le programme était de créer le formulaire je ne suis pas à l'abri de corrompre mon classeur de code.

-la deuxième c'est que créer des contrôles de manière dynamique dans classeur de code ou dans un classeur de résultat c'est pareil une fois qu'on a la bonne méthode de programmation.

-je voulais pas m'embêter à gérer des protections à tout va vu que je suis pas un expert là dedans.

-enfin pour la clarté du code.

-parce que la création dynamique est un truc qui me plaît bien

La procédure Test étant privée on ne peut y accéder depuis un autre classeur, Application.Run provoque donc une erreur "Impossible de trouver la macro..etc"

Je suis bien évidemment d'accord dans le principe mais à l'exécution j'ai pas de problème, je comprends pas.

Bonne soirée.

[tirex28]

Bonsoir,

à l'exécution j'ai pas de problème, je comprends pas.

Moi non plus..

Cordialement,

Tirex28/