Problème de scope lors de la création d'une Combobox ActiveX

**Patrick Seuret** · 04/03/2015, 10h06

Bonjour,

Voici le contexte de mon travail:

J'aimerais utiliser une combo à plusieurs colonnes et plus agréable à utiliser pour sélectionner une valeur de cellule parmi un très grand nombre de valeur (plusieurs centaine).

Pour cela, je crée une combobox ActiveX dans une fonction et je l'assigne à un objet de classe local qui doit gérer le changement de valeur et cacher la combo une fois que l'utilisateur aura sélectionné la valeur.

Mon problème:

Si je créer l'objet ActiveX et l'assigne à mon objet de classe dans la même fonction, alors ma classe est automatiquement détruite à la fin de la fonction, comme si j'avais une variable de scope local... Si je créer l'ActiveX dans une fonction et l'assigne dans une autre (par exemple avec 2 macro boutons), alors tout se passe correctement.

J'ai aussi un problème avec le debugger car je ne peux plus entrer en mode debuggage dans la fonction dès que l'objet ActiveX a été créé (message "Impossible d'entrer en mode arrêt maintenant").

Mon code:

J'arrive à reproduire le problème avec ce code:

1) Mon module de classe:

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
 
Option Explicit
Option Base 1
 
' Global objects
Private WithEvents gMSCombo As MSForms.Combobox ' OLEObject
 
' Create combo object
Public Sub Class_Initialize()
 
    Debug.Print "claSelectionCombo::Class_Initialize"
 
End Sub
 
Public Property Let Object(combo As MSForms.Combobox)
 
    Set gMSCombo = combo
 
End Property
 
 
Public Property Get value() As String
 
    value = gMSCombo.value
 
End Property
 
Public Property Let value(newValue As String)
 
    gMSCombo.value = newValue
 
End Property
 
' Delete combo object
Public Sub Class_Terminate()
 
    Debug.Print "claSelectionCombo::Class_Terminate"
 
End Sub

2) Mon module:

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
Option Explicit
Option Base 1


' Objects global to module
Private gSelectCombo As claSelectionCombo


Sub Bouton1_Cliquer()
    Dim obj As MSForms.Combobox
    Set obj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.ComboBox.1", _
                            Link:=False, _
                            DisplayAsIcon:=False).Object
    
    ' Problème dès que j'insère ces deux lignes:
    Set gSelectCombo = New claSelectionCombo
    gSelectCombo.Object = obj
    
End Sub

Sub Bouton2_Cliquer()

    Dim value As String
    Dim obj As MSForms.Combobox
    
    If (gSelectCombo Is Nothing) Then
        Debug.Print "Create class object"
        Set gSelectCombo = New claSelectionCombo
        Set obj = ActiveSheet.OLEObjects(1).Object
        gSelectCombo.Object = obj
    Else
        Debug.Print "Use existing class object"
    End If

    value = gSelectCombo.value
    
    Debug.Print "Value is: " & value
    MsgBox "Value is: " & value
    
End Sub

Si je mets les deux lignes indiquées dans le Bouton1, j'obtiens la sortie suivante sur la console:
claSelectionCombo::Class_Initialize
claSelectionCombo::Class_Terminate
Et un click sur le Bouton2 nécessite de réinitialiser ma classe (message "Create class object")

Savez-vous pourquoi j'ai ce comportement?
Comment puis-je assigner directement un objet ActiveX nouvellement créé à ma classe?

Par ailleurs, j'ai cherché de la documentation de référence sur les combobox ActiveX (pour connaître les événements observables, les propriétés, etc.) mais je n'ai pas trouvé sur le site de Microsoft (j'ai trouvé cette référence https://msdn.microsoft.com/en-us/lib.../ff840691.aspx mais elle n'indique pas les mêmes méthode que dans l'editeur VBA...). Savez-vous où je peux trouver de la documentation?

Merci par avance pour votre aide :-)

**patricktoulon** · 04/03/2015, 10h42

Bonjour
regarde dans les contribution l'effet mouse overin et regarde comment j'ajoute des controls button dans ma classe bouton

mais je comprend pas bien ce que tu cherche a faire avec tes combo dans le sheets
il y a peu être un moyen moins lourd d'avoir des liste de choix dynamique pour chaque cellule ou ligne

**Patrick Seuret** · 04/03/2015, 14h12

Bonjour,

J'ai cherché dans tes contributions (notamment nouveau effet mouse in out sur les boutons dans un userform sans les apis et fonction mouse over et mouse out pour les boutons de vos userforms) mais je n'ai pas trouvé de création dynamique de bouton: dans tes exemples, tu parcours à chaque fois les objets existant mais tu ne le crées pas.

J'ai essayé d'utiliser les listes de validations des données mais ça montre une toute petite fenêtre et on ne peut pas commencer à taper la valeur à chercher... Donc je me suis orienté vers une méthode plus agréable pour sélectionner une valeur parmi plus de 800 et pour l'instant je n'ai pas trouvé autre chose. Mais je suis à l'écoute si tu as des idées

**PMO2017** · 04/03/2015, 15h22

Bonjour,

@ Patrick Seuret

Pourriez-vous construire un classeur simple de ce que vous voulez obtenir (data à prendre en compte, résultat souhaité, cellule(s) où cela doit s'inscrire) car je n'ai pas trop compris votre demande.
La création dynamique de ComboBox (ou autre contrôle) est possible sur une feuille en tant qu'OleObject.

**patricktoulon** · 04/03/2015, 15h37

bonjour
si les liste de validation ne te conviennent pas j'opterais plutôt vers une commandebarpopup perso avec un listbox a l'interieur et un edit pour taper un indice de recherche

**Patrick Seuret** · 04/03/2015, 18h39

Bonjour PMO2017,

Désolé, j'aurais dû le faire tout de suite... Voici mon fichier minimum pour reproduire le problème:

POC Combobox.xlsm

Fonctionnement attendu:
1) Lorsque je clique sur le bouton "Créer": une combobox apparaît avec le contenu "Toto" (sur la cellule actuellement sélectionnée). Cette combo est sauvée dans la variable "gSelectCombo" du module
2) Lorsque je clique sur le bouton "Valeur": la valeur de la combo box est affiché.

Fonctionnement réel:
1) La combobox apparaît bien avec le texte "Toto". Par contre, l'objet global "gSelectCombo" est immédiatement détruit (affichage de "claSelectionCombo::Class_Terminate" dans la console)
2) L'objet de classe gSelectCombo n'est plus valide (égal à Nothing)...

En fait, c'est comme si l'événement "Cliquer()" du bouton "Créer" était exécuté dans un scope différent et "rendait" l'objet à la fin... D'ailleurs, j'ai testé: si on ajoute un appel à "Bouton1_Cliquer" au début de "Bouton2_Cliquer()", alors la méthode est correctement exécutée mais l'objet est aussi détruit à la fin... Je ne me l'explique pas.

Merci pour votre aide!
Patrick

@patricktoulon:

Oui, je peux aussi créer un objet cacher et ne le montrer que quand j'en ai besoin, mais là il y a un truc que je ne comprends pas et je sens que cela va m'embêter pour d'autres choses et j'aimerais bien comprendre avant de chercher un workaround

**PMO2017** · 05/03/2015, 04h06

Bonjour Patrick Seuret,

Merci pour votre fichier.
Cependant, je ne sais toujours pas qu'elle est la finalité de votre demande.
Vous ne spécifiez pas les data à prendre en compte, le résultat souhaité et la/les cellule(s) où il doit s'inscrire.

Votre demande est-elle :
1) La réalisation de ComboBox (OLEObject) dans une feuille pour faciliter des saisies ?
Auquel cas, il y aurait une vraie utilisation et une classe ne serait pas nécessaire.

OU

2) vous voulez utiliser une Classe dans un but didactique sans un véritable usage concret.

**Patrick Seuret** · 05/03/2015, 09h46

Bonjour,

La finalité de la demande est de sélectionner une personne parmi un grand nombre lorsque l'utilisateur sélectionne certaines cellules.

Je m'étais orienté vers un combo ActiveX car il permet d'afficher les valeurs dans deux colonnes (une avec le nom, l'autre avec le prénom) et lier le contenu d'une autre. L'utilité est qu'on affiche "Prénom Nom" dans la case mais que les personnes sont triées par nom: du coup la recherche est simplifiée en alignant les noms dans la colonne de la combo.

Le second avantage de l'ActiveX sur le contrôle combo standard (DropDown) est qu'on peut commencer à taper les premières lettres du nom pour retrouver la bonne personne...

Maintenant, au delà de la résolution pure de mon problème, je ne comprends pas pourquoi le débogueur ne fonctionne plus dès qu'un objet ActiveX est créé ni pourquoi ma classe s'autodétruit... Donc il y a aussi une composante didactique

Pour info, voici le code complet de mon module de classe (j'avais isolé le problème dans mes posts précédents pour faciliter la compréhension en éliminant les parties non impliquées):

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
 
' Class: Manage a combo to select value of a cell (c) P.Seuret v2015-02-24
 
' Versions:
'  2015-02-24: Creation of class
'
' References:
' http://www.excelforum.com/excel-programming-vba-macros/790311-class-module-with-activex-combobox.html
' https://msdn.microsoft.com/en-us/library/office/ff840691.aspx
' http://www.developpez.net/forums/d1503559/logiciels/microsoft-office/excel/macros-vba-excel/probleme-scope-lors-creation-d-combobox-activex/
'
' As standard controls:
' http://www.excel-easy.com/vba/examples/combo-box.html
 
Option Explicit
Option Base 1
 
' Global objects
Private WithEvents gMSCombo As MSForms.Combobox ' OLEObject
Private gIsBusy As Boolean
 
' Create combo object
Public Sub Class_Initialize()
 
    Debug.Print "claSelectionCombo::Class_Initialize"
    'Set gCombo = Nothing
    gIsBusy = False
 
End Sub
 
' Assign the combo to a cell to fill
'
' \param linkedCell is the source cell to link to the combo (get only the first cell if multiple selection)
' \param dataSource is a string defining the selection of data to fill the dropdown list with
' \param linkedColumn is the column of data to link to the cell
' \param columnWidths is the with of each column of the dropdown to show to the user. MUST be an array
'                    of double (in centimeters)
Public Sub AssignHost(linkedCell As Range, dataSource As String, linkedColumn As Integer, colWidths As Variant)
 
    Dim widths As String
    Dim totalW As Double
    Dim iWidth As Integer
    Dim aWidth As Double
    Dim hostCell As Range
    Dim hostSheet As Worksheet
    Dim found As Boolean
    Dim i As Integer
    Dim colCount As Integer
 
    On Error GoTo AssignHost_Error
 
    ' Lock state
    gIsBusy = True
 
    ' Init variables
    Set hostCell = linkedCell.Cells(1, 1)
    Set hostSheet = linkedCell.parent
 
    ' Create object if necessary
    If (gMSCombo Is Nothing) Then
            Set gMSCombo = hostSheet.OLEObjects.Add( _
                              ClassType:="Forms.ComboBox.1", _
                              Link:=False, _
                              DisplayAsIcon:=False _
                           )
    End If
 
 
    ' Link combo
    If (Not gMSCombo Is Nothing) Then
 
        Debug.Print "claSelectionCombo::AssignHost: object name is: " & gMSCombo.name
 
        ' Prepare width of dropbox and columns
        totalW = 0
        colCount = UBound(colWidths) - LBound(colWidths) + 1
        widths = vbNullString
        For iWidth = LBound(colWidths) To UBound(colWidths)
            aWidth = colWidths(iWidth)
            totalW = totalW + aWidth
            widths = widths & IIf(widths = "", "", ";") & aWidth & "cm"
        Next iWidth
 
        ' Init combo object
        With gMSCombo
            ' Set position
            .Top = hostCell.Top - 2
            .Left = hostCell.Left - 7
            .Width = hostCell.Width + 23
            .height = hostCell.height + 5
            ' Link data
            .ListFillRange = dataSource
            ' Define dropdown box
            If (colCount > 0) Then
                .ColumnCount = colCount
                .BoundColumn = linkedColumn
                .columnWidths = VBA.Replace(widths, ".", ",")
                .ListWidth = " " & totalW & "cm"
            End If
            .linkedCell = hostCell.address
            .ListRows = 20
 
            ' Define behaviour
            ' Nothing to do... managed by gMSCombo_Change()
 
        End With
 
        ' Make combo visible
        gMSCombo.Visible = True
 
    End If
 
    ' Finished
    GoTo AssignHost_End
 
AssignHost_Error:
    Debug.Print "claSelectionCombo::AssignHost: Error"
 
AssignHost_End:
    Debug.Print "claSelectionCombo::AssignHost: End"
    ' Unlock state
    gIsBusy = False
 
    ' Free memory
    Set hostCell = Nothing
    Set hostSheet = Nothing
 
End Sub
 
' Handle change of value un combo
Private Sub gMSCombo_Change()
 
    If (gIsBusy) Then
        Debug.Print "claSelectionCombo::gMSCombo_Change: Busy, ignore change!!"
    Else
        Debug.Print "claSelectionCombo::gMSCombo_Change: Ready to make some stuff!!"
    End If
    Debug.Print "claSelectionCombo::gCombo_Change (" & gMSCombo.Value & ")"
 
    ' Combo content changed: hide object
    'gMSCombo.Visible = False
 
End Sub
 
' Handle closing of combo dropdown window
Private Sub gMSCombo_AfterUpdate()
 
    Debug.Print "claSelectionCombo::gCombo_AfterUpdate!!"
 
End Sub
 
' Get current text value of the combobox
Public Function GetValue() As String
 
    If (Not gMSCombo Is Nothing) Then
        GetValue = gMSCombo.Value
    End If
 
End Function
 
' Is object busy ?
Public Property Get IsBusy() As Boolean
 
    IsBusy = gIsBusy
 
End Property
 
 
 
' Delete combo object
Public Sub Class_Terminate()
 
    Debug.Print "claSelectionCombo::Class_Terminate"
 
End Sub

**PMO2017** · 05/03/2015, 21h07

Bonjour,

La finalité de la demande est de sélectionner une personne parmi un grand nombre lorsque l'utilisateur sélectionne certaines cellules.
Je m'étais orienté vers un combo ActiveX car il permet d'afficher les valeurs dans deux colonnes (une avec le nom, l'autre avec le prénom) et lier le contenu d'une autre. L'utilité est qu'on affiche "Prénom Nom" dans la case mais que les personnes sont triées par nom: du coup la recherche est simplifiée en alignant les noms dans la colonne de la combo.

Un exemple qui devrait répondre à votre demande.

1) Copiez le code suivant dans la fenêtre de code de ThisWorkbook

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
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Dim OL As OLEObject
Dim Plage As Range
Dim C As Range
'--- Sort si ce n'est pas la bonne feuille ---
If Sh.Name <> MA_FEUILLE Then Exit Sub
Set Plage = Sh.Range(MA_PLAGE)
'--- Efface l'OLEObject (ComboBox) ---
For Each OL In Sh.OLEObjects
  If OL.progID = "Forms.ComboBox.1" Then
    If OL.Name = OLE_OBJ_NOM Then
      OL.Cut
      Set OL = Nothing
    End If
  End If
Next OL
'--- Efface les erreurs #NA ---
Application.EnableEvents = False
For Each C In Plage
  If IsError(C) Then
    C = vbNullString
  End If
Next C
Application.EnableEvents = True
'--- Création de la ComboBox ---
If Not Application.Intersect(Target, Plage) Is Nothing Then
  Call CreeComboBox
End If
End Sub

2) Copiez le code suivant dans un module Standard

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
'//////////////////////////////////////////
'/// Nécessite la librairie suivante    ///
'/// (faire menu Outils/Références...)  ///
'/// Library MSForms                    ///
'/// C:\WINDOWS\system32\FM20.DLL       ///
'/// Microsoft Forms 2.0 Object Library ///
'//////////////////////////////////////////
 
'### Constantes à adapter ###
Public Const MA_FEUILLE As String = "test"        'Feuille où agit la ComboBox
Public Const MA_PLAGE As String = "c1:c36"        'Plage où agit la ComboBox
Public Const OLE_OBJ_NOM As String = "___OLEpmo"  'Nom pour identifier l'OLEObject
'############################
 
Sub CreeComboBox(Optional dummy As Byte)
Dim OL As OLEObject
Dim CB As ComboBox
Dim S As Worksheet
Dim R As Range
Dim R2 As Range
Dim var
'---
Set R = ActiveCell
Set R2 = R.Offset(0, 1) 'On décale d'une colonne la présentation de la ComboBox
Set OL = ActiveSheet.OLEObjects.Add(ClassType:="Forms.ComboBox.1", Link:=False, _
        DisplayAsIcon:=False, Left:=R2.Left, Top:=R2.Top, Width:=300, Height:=30)
OL.Name = OLE_OBJ_NOM
'---
Set CB = OL.Object
Set S = Sheets("Data")
var = S.[a1].CurrentRegion
CB.List = var
CB.LinkedCell = R.Address
CB.ColumnCount = UBound(var, 2) 'Le nombre de colonnes = La dimension 2 du Variant tableau
CB.BoundColumn = 3    'La colonne de la ComboBox qui s'inscrira dans la cellule
End Sub

3) Adaptez à votre usage les constantes cernées par des ###
ainsi que l'instruction qui indique la colonne de la ComboBox qui sera prise en compte :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

CB.BoundColumn = 3    'La colonne de la ComboBox qui s'inscrira dans la cellule

**Patrick Seuret** · 10/03/2015, 18h08

Bonjour,

Merci pour cette proposition. Si j'ai bien compris, l'astuce consiste à utiliser le nom que l'on attribue à la combobox (à la ligne "OL.Name = OLE_OBJ_NOM") pour intercepter les événements depuis le module de la feuille. C'est dommage qu'on ne puisse pas gérer directement la création de l'objet OLE directement dans une classe ce qui aurait permis de mettre tout le code au même endroit et de généraliser l'usage via une classe autonome.

En fait, vu ces complications et les difficulté à m'assurer le bon traitement des événements (modification de la valeur, touche escape, enter, clic en dehors du dropdown, etc.) j'ai opté pour une autre solution qui répond mieux à mes besoins et m'a permis d'ajouter un système de filtre des données.

Pour information, voici ce que ça donne:
1) J'ai créé un UserForm (dont le nom est "UserFormSelectEmployee") avec:
- Une zone de texte (TextBox) pour le filtre (nom=txtFilter)
- Une case à cocher (CheckBox) pour filtrer uniquement par le début des noms ou n'importe où (nom=chkFullSearch)
- Une zone d'affichage des nombe (ListBox) (nom=lstEmployees)
- Un bouton "ok" (CommandButton, nom=cmdOk)
- Un bouton "annuler" (CommandButton, nom=cmdCancel)
- La propriété "ShowModal" du UserForm est à "True"
Nom : Capture.PNG
Affichages : 450
Taille : 10,6 Ko

Nom : Capture.PNG
Affichages : 450
Taille : 10,6 Ko

2) Le code de ce userform:

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
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
' Module: User form to select an employees (c) P.Seuret v2015-03-06a
'
' Can't use RowSource of ListBox to filter data because it is strongly related
' to the data range. We thus choose store source data into an array (gDataSource)
' and load only items containing the filter value
'
 
' Global objects
Private gLinkedCell As Range
Private gDataSource() As Variant
 
' Set data source of the selector
Public Sub OpenForm(linkedCell As Range, dataSource As Range, linkedColumn As Integer, colWidths As Variant)
 
    Dim hostCell As Range
    Dim hostSheet As Worksheet
    Dim widths As String
    Dim totalW As Double
    Dim iWidth As Integer
    Dim colCount As Integer
    Dim currentValue As String
    Dim countItems As Integer
    Dim dataRange As Range
    Dim iRow As Integer
    Dim iCol As Integer
    Dim rowCount As Integer
 
    On Error GoTo OpenForm_Error
 
    ' Check parameters
    If ((linkedCell Is Nothing) Or (dataSource Is Nothing)) Then
        GoTo OpenForm_End
    End If
 
    ' Init variables
    Set hostCell = linkedCell.Cells(1, 1)
    Set hostSheet = linkedCell.parent
 
    ' Get values of dataSource range in gDataSource array
    rowCount = dataSource.Rows.count
    colCount = UBound(colWidths) - LBound(colWidths) + 1
    colCount = IIf(colCount < dataSource.Columns.count, colCount, dataSource.Columns.count)
    gDataSource = Range(dataSource.Cells(1, 1), dataSource.Cells(rowCount, colCount))
 
    ' Prepare width of columns
    totalW = 0
    widths = vbNullString
    For iWidth = LBound(colWidths) To UBound(colWidths)
        aWidth = colWidths(iWidth)
        totalW = totalW + aWidth
        widths = widths & IIf(widths = "", "", ";") & aWidth & "cm"
    Next iWidth
 
    ' Set parameters of the listbox
    With lstEmployees
        '+PSE:2015-03-06:Replaced by array to allow filtering
        '.RowSource = dataSource
        '-PSE:2015-03-06
        If (colCount > 0) Then
            .ColumnCount = colCount
            .columnWidths = VBA.Replace(widths, ".", ",")
        Else
            .ColumnCount = 1
            .columnWidths = vbNullString
        End If
        .BoundColumn = linkedColumn
    End With
 
    ' Load data into listbox with no filtering
    txtFilter.text = vbNullString
    LoadAndFilterDataItems
 
    ' Keep linked cell for later assignation of result value
    Set gLinkedCell = hostCell
 
    ' Preselect current value
    countItems = lstEmployees.ListCount
    currentValue = hostCell.Value
    lstEmployees.ListIndex = -1
    If (currentValue <> "") Then
        For iItem = 0 To (countItems - 1)
            If (lstEmployees.List(iItem) = currentValue) Then
                lstEmployees.ListIndex = iItem
                Exit For
            End If
        Next iItem
    End If
 
    ' Make form visible
    Me.Show
 
    ' Done
    GoTo OpenForm_End
 
OpenForm_Error:
    Debug.Print "UserFormSelectEmployee::OpenForm: Error"
 
OpenForm_End:
    ' Free memory
    Set hostCell = Nothing
    Set hostSheet = Nothing
    Set dataRange = Nothing
 
End Sub
 
' Load data in listbox
Private Sub LoadAndFilterDataItems(Optional filter As String = vbNullString, _
                                   Optional fullSearch As Boolean = False)
 
    Dim iRow As Integer
    Dim rowCount As Integer
    Dim iCol As Integer
    Dim iColFilter As Integer
    Dim colCount As Integer
    Dim filterLen As Integer
    Dim filterValue As String
    Dim doMatch As Boolean
    Dim isScreenUpdating As Boolean
 
    On Error GoTo LoadAndFilterDataItems_Error
 
    ' Lock display
    isScreenUpdating = Application.ScreenUpdating
    Application.ScreenUpdating = False
 
    ' Init variables
    rowCount = 1 + UBound(gDataSource, 1) - LBound(gDataSource, 1)
    colCount = 1 + UBound(gDataSource, 2) - LBound(gDataSource, 2)
    If ((rowCount = 0) Or (colCount = 0)) Then
        Exit Sub
    End If
 
    ' Clear old data
    lstEmployees.Clear
 
    ' Fill listbox
    If (filter = "") Then
        ' No filter... Load quickly
        With lstEmployees
            For iRow = 1 To rowCount
                .AddItem gDataSource(iRow, 1)
                If (colCount > 1) Then
                    For iCol = 2 To colCount
                        .List(iRow - 1, iCol - 1) = gDataSource(iRow, iCol)
                    Next iCol
                End If
            Next iRow
        End With
    Else
        'Apply filter (case insensitive)
        filterValue = VBA.LCase(txtFilter.text)
        filterLen = VBA.Len(filterValue)
        With lstEmployees
 
            For iRow = 1 To rowCount
                ' Does item match filter ?
                For iColFilter = 1 To colCount
                    If (fullSearch) Then
                        doMatch = (VBA.InStr(1, VBA.LCase(gDataSource(iRow, iColFilter)), filterValue) > 0)
                    Else
                        doMatch = (VBA.LCase(VBA.Left(gDataSource(iRow, iColFilter), filterLen)) = filterValue)
                    End If
 
                    If (doMatch) Then
                        ' Yes! Add as new item
                        .AddItem gDataSource(iRow, 1)
                        If (colCount > 1) Then
                            For iCol = 2 To colCount
                                .List(.ListCount - 1, iCol - 1) = gDataSource(iRow, iCol)
                            Next iCol
                        End If
                        ' Stop filter search for this row
                        Exit For
                    End If
                Next iColFilter
            Next iRow
        End With
    End If
    ' Finished
    GoTo LoadAndFilterDataItems_End
 
LoadAndFilterDataItems_Error:
    Debug.Print "UserFormSelectEmployee::LoadAndFilterDataItems: Error"
 
LoadAndFilterDataItems_End:
    ' Restore display
    Application.ScreenUpdating = isScreenUpdating
 
    ' Free memory
 
End Sub
 
' Reset and close form
Private Sub CloseForm()
 
    On Error Resume Next
 
    ' Reset parameters
    Erase gDataSource
    Set gLinkedCell = Nothing
    lstEmployees.RowSource = vbNullString
    txtFilter.text = vbNullString
 
    ' Hide form
    Me.Hide
 
End Sub
 
Private Sub chkFullSearch_Click()
 
    ' Same as a change in filter
    txtFilter_Change
 
End Sub
 
' User cancel his choice
Private Sub cmdCancel_Click()
 
    CloseForm
 
End Sub
 
' User apply his choice
Private Sub cmdOk_Click()
 
    Dim Result As String
    If (Not gLinkedCell Is Nothing) Then
        If (lstEmployees.ListIndex >= 0) Then
            gLinkedCell.Value = lstEmployees.List(lstEmployees.ListIndex)
        Else
            gLinkedCell.Value = vbNullString
        End If
    End If
 
    CloseForm
 
End Sub
 
' User make his choice
Private Sub lstEmployees_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
 
    cmdOk_Click
 
End Sub
 
' Apply filter to the list
Private Sub txtFilter_Change()
 
    Dim dataSource As String
    Dim filterValue As String
    Dim isFullSearch As Boolean
    Dim isScreenUpdating As Boolean
 
    On Error GoTo txtFilter_Change_Error
 
    ' Lock display
    isScreenUpdating = Application.ScreenUpdating
    Application.ScreenUpdating = False
 
    ' Get parameters
    isFullSearch = chkFullSearch.Value
    filterValue = txtFilter.text
 
    ' Filter data
    LoadAndFilterDataItems filter:=filterValue, fullSearch:=isFullSearch
 
    ' Finished
    GoTo txtFilter_Change_End
 
txtFilter_Change_Error:
    Debug.Print "UserFormSelectEmployee::txtFilter_Change: Error"
 
txtFilter_Change_End:
    ' Restore display
    Application.ScreenUpdating = isScreenUpdating
 
    ' Free memory
 
End Sub
 
 
Private Sub UserForm_Activate()
 
    ' Give focus to the filter text
    txtFilter.SetFocus
 
End Sub

2) Et ce formulaire est appelé comme suit (initialisation et récupération de la valeur sélectionnée):

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
' Patrick Seuret, 24.02.2015
'
' Allow user to select an employee with a more confortable combo than "Valid Data" list
' \param target is the cell range to change the value of
' Reference: http://www.get-digital-help.com/2011/12/21/working-with-combo-boxes-form-control-using-vba/
' Employees data are stored in a sheet area named "MainData":
Private Const cMainData As String = "MainData"
Public Sub UserSelectEmployee(target As Range)
 
    Dim hostSheet As Worksheet
    Dim hostCell As Range
    Dim dataSource As Range
 
    On Error GoTo UserSelectEmployee_Error
 
    ' Check parameters
    If (target Is Nothing) Then Exit Sub
    If (target.count = 0) Then Exit Sub
 
    ' Init variables
    Set hostCell = target.Cells(1, 1)
    Set hostSheet = target.parent
    Set dataSource = ActiveWorkbook.Names(cMainData).RefersToRange
 
    ' Show selector
    ' MainData contains 4 columns: 
    ' - 1st is the value to bound (as defined in 3rd parameter of call) but hidden (width=0), 
    ' - 2nd is not used here (hidden: width=0),
    ' - 3rd is first name (visible: width=3.5 cm)
    ' - 4th is last name (visible: width=3.5 cm)
    UserFormSelectEmployee.OpenForm hostCell, dataSource, 1, Array(0, 0, 3.5, 3.5)
 
    ' Finished
    GoTo UserSelectEmployee_End
 
UserSelectEmployee_Error:
    Debug.Print "LocalFunctions::UserSelectEmployee: Error"
 
UserSelectEmployee_End:
    ' Free memory
    Set hostCell = Nothing
    Set hostSheet = Nothing
    Set dataSource = Nothing
 
End Sub

**PMO2017** · 10/03/2015, 19h19

Merci pour cette proposition. Si j'ai bien compris, l'astuce consiste à utiliser le nom que l'on attribue à la combobox (à la ligne "OL.Name = OLE_OBJ_NOM") pour intercepter les événements depuis le module de la feuille.

Non
Cela sert à identifier précisément l'OLEObject que l'on a construit pour le détruire.
Si vous utilisez d'autres OLEObjects ComboxBox sur votre feuille, il convient de les laisser en place et de supprimer uniquement celui qui nous a servi.

**Patrick Seuret** · 10/03/2015, 22h01

Désolé, je n'avais pas fait attention. Du coup, je ne vois pas comment sont intercepté les événements de la Combo (j'ai compris que la cellule est liée via CB.LinkedCell = R.Address).

**PMO2017** · 10/03/2015, 22h25

je ne vois pas comment sont intercepté les événements de la Combo (j'ai compris que la cellule est liée via CB.LinkedCell = R.Address).

Le simple fait de sélectionner un item de la ComboBox renseigne la celule qui lui est liée.
Cela ne déclenche aucun évènement de feuille.
***
L'évènement Workbook_SheetSelectionChange sert à détruire l'ancien OLEObject et à en construire un nouveau.
Il sert également à nettoyer la valeur d'erreur #NA qui se produit si aucun item de la ComboBox n'a été sélectionné ET qu'on a changé de cellule.

**Patrick Seuret** · 10/03/2015, 22h56

ok, merci

Problème de scope lors de la création d'une Combobox ActiveX [XL-2010]

Macros et VBA Excel

Discussions similaires

Partager

Partager