Création automatique d'un Userform en VBA sous OUTLOOK

**Brenten** · 27/09/2019, 17h54

Bonjour,

Je vous écris pour solliciter votre aide, sous VBA Outlook.
Je souhaiterai pouvoir créer via une macro un Userform à la volé et apres sa fermeture, qu'il soit détruit

J'ai bien le code qui me permet de créer automatiquement un userform sous Excel en VBA (cf dessous)

Mais impossible d'y arriver sous Outlook.
ni en remplaçant "ThisWorkBook" par "ThisOutlooksession" ... ce serait trop beau ...
ni avec VBIDE
ni avec COM Add-in

Si qu'un avait une solution ?

Code :

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
 
 
Dim UsfForm As Object   
Set UsfForm = ThisWorkbook.VBProject.VBComponents.Add(3)  
 
' ==============================> ses Paramètres  <========================
 
    With UsfForm
        .Properties("Caption") = " Titre de l'userform"
        .Properties("Width") = UsfWidth
        .Properties("Height") = UsfHeight
        .Properties("backcolor") = RGB(230, 230, 230)
        .Properties("StartUpPosition") = 0
        .Properties("Left") = Application.UsableWidth / 4
        .Properties("Top") = Application.UsableHeight / 4
    End With
 
' ==============================> son bouton / et d'autres ... <========================
 
    Set NewB = UsfForm.Designer.Controls.Add("Forms.CommandButton.1") ' mon bouton 
    With NewB
        .Height = 30
        .Width = 80
        .Left = UsfWidth / 2 - 40
        .Top = 10
        .Caption = "Fermer"
    End With
 
' ==============================> Intégration du code dans le userform <===========================
    With UsfForm.CodeModule
            i = .CountOfLines
            If i = 2 Then
                .insertlines i, "": i = i + 1
            Else
                i = 1
            End 
            .insertlines i, "Private Sub CommandButton1_Click()": i = i + 1
            .insertlines i, " ' Mon code ": i = i + 1
            .insertlines i, "       Unload Me": i = i + 1
            .insertlines i, "   End Sub": i = i + 1
    End With
 
 
' =====================> Affiche l'userform <=================
    VBA.UserForms.Add(UsfName).Show
 
' ===================================> détruit l'userform quand il est fermé <==========================
ActiveWorkbook.VBProject.VBComponents.Remove VBComponent:=UsfForm

Un grand merci à tous pour votre aide.

Brenten

**Brenten** · 27/09/2019, 17h56

Pour ceux qui voudraient plus de détail
je joins le code complet fonctionnel sous Excel .. mais pas sur Outlook justement ..

merci encore pour votre aide

Brenten

Code :

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
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
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
 
 
Sub UserformCreation()
 
            Dim UsfForm As Object                   ' objet Userform générique
            Dim NewB As MSForms.CommandButton       ' objet bouton à cliquer générique
            Dim ChkB As MSForms.CheckBox            ' objet case à cocher générique
            Dim i As Long, j As Long                ' incrément pour code VB
            Dim k As Integer                        ' boucle ET NUMERO DE LA LIGNE DE LA TACHE LE FICHIER
            Dim UsfName As String                   ' nom de l'userform
            Dim UsfHeight As Long                   ' hauteur du userforme
            Dim LockHeight As Long                  ' lockup pour la hauteur
            Dim UsfWidth As Long                    ' Largeur du userforme
            Dim iLeft As Long, iTop As Long         ' variable de positionnement des checkbox
            Dim NbCheckbox As Integer               ' nb de checkbox
            Dim User_id As String                   ' id windows
            Dim Task_date As Date                   ' date de la tache testée
            Dim Relance1  As Long, Relance2 As Long ' nb jour(s )de déclanchement des  relance
            Dim task_clr As Integer                 ' different type de cas d'échéance 1,2 ou 3
            Dim lastlgn As Long                     ' nombre de taches dans le recordset
            Dim Task_content As String              ' chaine de caractère qui sera affiché dans la relance checkbox
            Dim cn As ADODB.Connection              ' Definition d'une connexion
            Dim Fichier As String                   ' Nom du fichier
            Dim NomFeuille As String                ' nom feuille
            Dim rst As ADODB.Recordset              ' Définition du resultat de la requete SQL
 
 
 
 
' ===================================> URL DE LA BASE EXCEL  <===================================
 
            Fichier = "C:\test\TACHESTEST.xlsx"     ' nom du classeur cible
 
 
' ===================================> PARAMETRE <===================================
            NomFeuille = "TACHE" & "$"              ' Nom de la feuille dans le classeur cible, /!\ toujours mettre $ à la fin
            Cellule = "A1:I10000"                   ' Adresse de la cellule contenant la donnée à récupérer
            User_id = Environ("username")           ' Id de l'utilisateur windows
 
            iLeft = 10: iTop = 50                   ' Position de départ des items dans l'userform
            LockHeight = 0                          ' Parametre Userform : bloque la taille max
            NbCheckbox = 0                          ' Nb de task à creer dans l'userform => compteur augmentant
            UsfWidth = 325                          ' Parametre Userform :largeur initial => peut augmenter
            UsfHeight = 80                          ' Parametre Userform : hauteur initial => peut augmenter
 
 
 
'    Application.VBE.MainWindow.Visible = False ' fermer la page VBA
 
 
 
' ===================================> Connexion ADO <===================================
 
    Set cn = New ADODB.Connection
    With cn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
            & Fichier & ";Extended Properties=""Excel 12.0;HDR=YES;"""     ' Excel 12 correspond à la version d'Excel installé, A mettre à jour si update Excel
        .Open
    End With
 
' ===================================> REQUETE SQL POUR RECUPERER LE RESULTAT <===================================
 
   Set ADOCommand = New ADODB.Command
    With ADOCommand
        .ActiveConnection = cn
        .CommandText = "SELECT * FROM [" & NomFeuille & Cellule & "]"
    End With
    Set rst = New ADODB.Recordset
        rst.Open ADOCommand, , adOpenKeyset, adLockOptimistic
    Set rst = cn.Execute("[" & NomFeuille & Cellule & "]")
 
 
 
' ===================================> Création du caneva de userform <===================================
 
    Set UsfForm = ThisWorkbook.VBProject.VBComponents.Add(3)
    'Set UsfForm = ThisOutlookSession.VBProject.VBComponents.Add(3)
    UsfName = UsfForm.Name
 
 
 
' ==========================================================================================================
' ==========================================================================================================
' ============================================> TRAITEMENT DU RECORDSET <===================================
' ==========================================================================================================
' ==========================================================================================================
 
 
 
 
' ===================================> GENERATION DES TACHES <===================================
 
    lastlgn = rst(8) ' récupération du nombre total de tache dans le recordset
 
 
' ===================================> /!\ /!\ /!\ /!\ <===================================
'
'           Attention la 1er colone d'un recordset est toujours numéroté 0
'           Décallage dans la numérotation par rapport à un Excel
'
' ===================================> /!\ /!\ /!\ /!\ <===================================
 
 
    For k = 1 To lastlgn                        ' Boucle sur tout le recordset
 
    If rst(3) = User_id And rst(7) <> "OK" Then ' verifier identité par ligne de recordset
 
            If iTop > 492 Then
                iTop = 50: iLeft = iLeft + 310  ' retour à la ligne si il y a 28 taches
                UsfWidth = UsfWidth + 310       ' augmente la largeur de l'userform
                LockHeight = 1                  ' bloque la hauteur limite
            End If
 
            If LockHeight = 0 Then UsfHeight = UsfHeight + 17 ' augmente la hauteur de l'userform si pas de lock
 
 
            Task_date = rst(4)                  ' Date de la tache
            Relance1 = rst(5)                   ' Délais avant relance 1
            Relance2 = rst(6)                   ' Délais avant relance 2
 
            If Task_date - Relance1 > Date Then GoTo jump_task
            If Date > Task_date - Relance1 Then task_clr = 1
            If Date > Task_date - Relance2 Then task_clr = 2
            If Date > Task_date Then task_clr = 3
 
            Task_content = " |" & rst(0) & "|  " & rst(1) & " - " & rst(2) & " - " & Task_date     ' Libellé de la Tache
 
            Set ChkB = UsfForm.Designer.Controls.Add("Forms.CheckBox.1")
            With ChkB
                .Height = 15
                .Width = 300
                .Left = iLeft
                .Top = iTop
                .Caption = Task_content
 
                Select Case task_clr
 
                    Case 1                                  ' Relance2  => VERT
                        .BackColor = RGB(112, 173, 71)
                        .ForeColor = RGB(0, 0, 0)
                    Case 2                                  ' Relance1  => ORANGE
                        .BackColor = RGB(255, 192, 0)
                        .ForeColor = RGB(0, 0, 0)
                    Case 3                                  ' Retard    => ROUGE
                        .BackColor = RGB(192, 0, 0)
                        .ForeColor = RGB(255, 255, 255)
 
                End Select
            End With
            iTop = iTop + 17                    ' Prochaine coordonnées de la checkbox suivante
            NbCheckbox = NbCheckbox + 1         ' compte le nombre de Checkbox
 
    End If
 
jump_task:
    rst.Move 1                                  ' passe à la ligne suivante du recordset
    Next k
 
' ===================================> Redimensionnement du Userform <===================================
 
    With UsfForm
        .Properties("Caption") = "             Vous avez " & NbCheckbox & " Tache(s) à traiter"
        .Properties("Width") = UsfWidth
        .Properties("Height") = UsfHeight
        .Properties("backcolor") = RGB(230, 230, 230)
        .Properties("StartUpPosition") = 0
        .Properties("Left") = Application.UsableWidth / 4
        .Properties("Top") = Application.UsableHeight / 4
    End With
 
' ===================================> creation bouton "Valider Tache(s)" <==============================================
 
    Set NewB = UsfForm.Designer.Controls.Add("Forms.CommandButton.1")
    With NewB
        .Height = 30
        .Width = 80
        .Left = UsfWidth / 2 - 40
        .Top = 10
        .Caption = "Valider Tache(s)"
    End With
 
 
 
' ===================================> Ecriture du code VB dans l'Userform  <==============================================
    With UsfForm.CodeModule
            i = .CountOfLines
            If i = 2 Then
                .insertlines i, "": i = i + 1
            Else
                i = 1
            End If
 
' -------------------------------------------------------
            .insertlines i, "Private Sub CommandButton1_Click()": i = i + 1
            .insertlines i, "Dim i as Long": i = i + 1
            .insertlines i, "Dim j as Integer": i = i + 1
            .insertlines i, "Dim sSQL As String": i = i + 1
            .insertlines i, "Dim k As String": i = i + 1
            .insertlines i, "Dim Fichier As String": i = i + 1
            .insertlines i, "Dim cn As New ADODB.Connection": i = i + 1
            .insertlines i, "": i = i + 1
 
            .insertlines i, "Fichier = """ & Fichier & """": i = i + 1
            .insertlines i, "": i = i + 1
            .insertlines i, "warn = MsgBox(""Confirmer la(es) taches faite(s) ?"", vbYesNo,"""")": i = i + 1
            .insertlines i, "If warn <> vbYes Then GoTo jump": i = i + 1
            .insertlines i, "": i = i + 1
 
' -------------------------------------------------------
            .insertlines i, "With cn": i = i + 1
            .insertlines i, "   .Provider = ""Microsoft.Jet.OLEDB.4.0""": i = i + 1
            .insertlines i, "    .ConnectionString = ""Provider=Microsoft.ACE.OLEDB.12.0;Data Source="" _": i = i + 1
            .insertlines i, "        & Fichier & "";Extended Properties=""""Excel 12.0;HDR=YES;""""""": i = i + 1
            .insertlines i, "    .Open": i = i + 1
            .insertlines i, "End With": i = i + 1
            .insertlines i, "": i = i + 1
 
' -------------------------------------------------------
            .insertlines i, "For Each Ctrl In Me.Controls": i = i + 1
            .insertlines i, "": i = i + 1
            .insertlines i, "    If TypeOf Ctrl Is MSForms.CheckBox And Ctrl.Object.Value = True Then": i = i + 1
            .insertlines i, "            With Ctrl.Object": i = i + 1
            .insertlines i, "                    i = InStr(.Caption, ""|"")": i = i + 1
            .insertlines i, "                    j = InStr(i + 1, .Caption, ""|"")": i = i + 1
            .insertlines i, "                    k = Mid(.Caption, i + 1, j - 1 - i)": i = i + 1
            .insertlines i, "            End With": i = i + 1
            .insertlines i, "": i = i + 1
            .insertlines i, "            sSQL = ""UPDATE  [TACHE$] SET Fait = 'OK' WHERE id = '"" & k & ""'""": i = i + 1
            .insertlines i, "            cn.Execute sSQL": i = i + 1
            .insertlines i, "            k = 0": i = i + 1
            .insertlines i, "            i = 0": i = i + 1
            .insertlines i, "            j = 0": i = i + 1
            .insertlines i, "    End If": i = i + 1
            .insertlines i, "": i = i + 1
            .insertlines i, "Next Ctrl": i = i + 1
            .insertlines i, "": i = i + 1
 
 ' -------------------------------------------------------
            .insertlines i, "jump:": i = i + 1
            .insertlines i, "       Unload Me": i = i + 1
            .insertlines i, "   End Sub": i = i + 1
            .insertlines i, "   ": i = i + 1
 
 
    End With
 
 
 
' ===================================> Affiche l'userform <==============================================
    VBA.UserForms.Add(UsfName).Show
 
' ===================================> détruit l'userform quand il est fermé <==============================================
    On Error Resume Next
        ActiveWorkbook.VBProject.VBComponents.Remove VBComponent:=UsfForm ' Sous Excel
        'ThisOutlookSession.VBProject.VBComponents.Remove VBComponent:=UsfForm ' Sous Outlook
    On Error GoTo 0
 
 
    '--- supprime le résultat ---
    rst.Close
 
'------------------------- Fermeture connexion vers le fichier -------------------------------------
    cn.Close
    Set cn = Nothing
 
 
 
 
End Sub

**Oliv-** · 30/09/2019, 10h28

Bonjour,
Ce n'est pas possible, outlook ne disposant pas de l'objet VBProject.

Tu peux sans doute contourner le problème en pilotant excel et en faisant créer ton userform dans EXCEL.
Sinon regarde du coté des Formulaires HTML

**Brenten** · 30/09/2019, 13h53

Bonjour Oliv-

merci de ta réponse,

j'entends bien qu'il n'y ait pas de VBProject sous Outlook, mais étant donné qu'il possible de créer un userform sous "ThissessionOutlook" au même titre que les modules et modules de class, je me suis dis qu'il y a bien un moyen de contourner le problème et forcer la création d'un template userforme en VB, sans jsutement devoir passer par la case VBA-Excel.

Après l'idée de passer par du HTML, pourquoi pas, mais je suis moins à l'aise pour créer à la voler une page avec des checkbox en nombre variable en fonction du nombre de résultat(s) dans mon recordset.

Création automatique d'un Userform en VBA sous OUTLOOK

VBA Outlook

Discussions similaires

Partager

Partager