Discussion :

[seb360]

Bonjour à tous,

J'ai trouvé un petit code sympa pour créer des checkboxes dynamiquement et j'essai maintenant sans succès de leur attribuer une macro commune via un module de classe mais cela ne fonctionne pas !!! Est-ce possible avec des checkboxes sur une feuille ou uniquement pour des formulaires ?? Je n'ai aucun message d'erreurs, la macro du module de classe ne s'exécute pas !

Quelqu'un peut-il m'aider ?? J'ai joint un petit fichier...


Voici le code de la feuille de calcul :

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
Private Sub CommandButton1_Click()
 
Dim ThePlage As Range, Cell As Range
Dim Cbx As OLEObject
Dim L As Double, T As Double, W As Double, H As Double
 
Set ThePlage = ActiveSheet.Range("C2:C20")
 
For Each Cbx In ActiveSheet.OLEObjects
If TypeOf Cbx.Object Is MSForms.CheckBox Then
Cbx.Delete
End If
Next Cbx
 
For Each Cell In ThePlage
L = Cell.Left
T = Cell.Top
W = Cell.Width
H = Cell.Height
 
Set Cbx = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", _
Left:=L, Top:=T, Width:=W, Height:=H)
With Cbx
.Name = "CheckBox" & i
.Object.Font.Size = 8
.Object.Caption = ""
.Object.Value = False
End With
Next Cell
 
initcheck
 
End Sub

Celui du 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
Option Explicit
Public Collect As Collection
Public Sub initcheck()
'Gestion de la collection (liste) des checkboxes
Dim obj As OLEObject
Dim CO As Classe1
Set CO = Nothing
Set Collect = New Collection
 
For Each obj In Sheets("Interface").OLEObjects
If TypeOf obj.Object Is MSForms.CheckBox Then
Set CO = New Classe1
Set CO.Checkboxgroup = obj.Object
Collect.Add CO
End If
Next
End Sub

et celui du module de classe :

Code :

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

1
2
3
4
5
6
7
8
Option Explicit
Public WithEvents Checkboxgroup As MSForms.CheckBox
 
Private Sub CheckboxGroup_Click()
 
MsgBox "TOTO"
 
End Sub

Merci pour votre aide