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