Checkbox et événement dynamiques

[Emeric]

Bonjour à tous,

Novice du VBA, j'utilise Excel version 2002 et je tente désespérément de créer des checkbox et leur événement "click" associé de façon dynamique dans une macro VBA. En effet selon les cas je peux avoir besoin d'une jusqu'à N checkbox.

J’ai donc inséré dans un module du code qui génère des chekbox et leur événement click sur une feuille excel. Les checkbox se créent bien mais je bute sur les événements.

Excel semble créer automatiquement un événement click lié à une check box générée dynamiquement (voir list box au dessus du code qui répertorie les fonctions d’une worksheet). J'ai donc utilisé une première méthode :

-Méthode 1
ActiveWorkbook.VBProject.VBComponents("Feuil1").CodeModule.ProcBodyLine("CB" & i & "_Click", vbext_pk_Proc)
Cette fonction est sensée me retourner la ligne de l’occurrence de la fonction « CB_click() » (histoire d’insérer mon code ensuite). Cette fonctionne me retourne rien au premier lancement de la macro. Elle me retourne quelque chose uniquement si je vais dans la fameuse listbox, sélectionne par ex CB1_click() pour la faire apparaître en dessous dans le code et relance la macro. Pour 100 check box ça risque d’être long !

-Méthode 2 (Plan B) ActiveWorkbook.VBProject.VBComponents("Feuil1").CodeModule.CreateEventProc("CB" & i & "_Click", Obj1.Name)
Cette fonction crée un événement lié à un objet. Je génère une erreur « 440, gestionnaire d’événement non valide ».

Désolé d’avance si mes explications sont longues et confuses. Je n’hésiterai pas à clarifier les points obscurs.

Grand merci d’avance à tous ceux qui peuvent m’aider : une solution, une fonction, une piste, ou même un encouragement car là j’en peux plus !

Mais surtout s’il vous plait dites moi que c‘est possible ! ;-)

Code :

ActiveSheet.OLEObjects.Delete
Dim i As Integer
Dim DebutCode As Integer

For i = 1 To 10

Dim Obj1 As OLEObject

L = Range("C" & i).Left + 3
T = Range("C" & i).Top + 3
W = 10
H = 10

Set Obj1 = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", Link:=False, DisplayAsIcon:=False, Left:=L, Top:=T, Width:=W, Height:=H)

Obj1.Name = "CB" & i
Obj1.Object.Value = True

DebutCode = ActiveWorkbook.VBProject.VBComponents("Feuil1").CodeModule.CreateEventProc("CB" & i & "_Click", Obj1.Name)
'DebutCode = ActiveWorkbook.VBProject.VBComponents("Feuil1").CodeModule.ProcBodyLine("CB" & i & "_Click", vbext_pk_Proc)
ActiveWorkbook.VBProject.VBComponents("Feuil1").CodeModule.InsertLines DebutCode + 1, "MsgBox ""YO!"""

Next i

 

[Zon]

Salut,

La méthode1 tu pourrais utliser replacelines mais c pas terrible dans ton cas.

Pour la 2, il ne faut aps écrire CreateEventProc("CB" & i & "_Click", Obj1.Name) mais CreateEventProc("Click", Obj1.Name) .

Voici un exemple où on supprime le cas échéant une à une les procédures. Si tu veux supprimer tout le code en une seule fois tu peux utliser:

Sub SupprCodeModule(C As Workbook, NomModule$)
With C.VBProject.VBComponents(NomModule).CodeModule
.DeleteLines 1, .CountOfLines
End With
End Sub

Le code

Sub Test()
Dim I As Integer
Dim F As Worksheet
Dim Code$

Set F = ActiveSheet
F.OLEObjects.Delete
For I = 1 To 10
Code = "msgbox ""yoyo"" & " & I & ""
SupprUneProc ThisWorkbook, F.CodeName, "CB" & I & "_click"
AjouterUnObj F, "forms.checkbox.1", Array(Ch, F.Range("C" & I).Left + 3, F.Range("C" & I).Top + 3, 10, 10, "")
AjouterProcEven ThisWorkbook, F.CodeName, "Click", Ch, Code
Next I
SendKeys "%{F11}" 'pour fermer VBE
End Sub

Sub AjouterUnObj(F As Worksheet, Objet$, Optional T)
Dim B As OLEObject
Set B = F.OLEObjects.Add(Objet)
If IsMissing(T) Then Exit Sub
With B
.Name = T(0)
.Left = T(1)
.Top = T(2)
.Width = T(3)
.Height = T(4)
.Object.Caption = T(5)
End With
End Sub

Sub AjouterProcEven(C As Workbook, NomModule$, Evenement$, Objet$, Code$)
With C.VBProject.VBComponents(NomModule).CodeModule
.InsertLines .CreateEventProc(Evenement, Objet) + 1, Code
End With
End Sub

Sub SupprUneProc(C As Workbook, NomModule$, NomProc$)
On Error Resume Next
With C.VBProject.VBComponents(NomModule).CodeModule
.DeleteLines .ProcStartLine(NomProc, 0), .ProcCountLines(NomProc, 0)
End With
End Sub

Chez moi la désactivation du rafraîchissement d'écran me plante Excel sur ce type de procédure qui modifie VBE....

A+++

 

[Zon]

Re,

C'est pas Ch mais "Cb" & I qu'il faut mettre.

A+++

 

[Emeric]

For i = 1 to 1000

Merci Zon ! Tu m'enlèves une fière chandelle du pied! Sans toi je crois que j'aurais fini par arracher toutes les touches de mon clavier une par une (état de frénésie compulsive proche du toc lorsque je craque nerveusement, certains se rongent les ongles, chacun son truc)

Next i

Maintenant, j'essaie de mettre mes check box à l'état True (et là j'aurais fini). Mettre .Object.Value = True dans le with de la fonction de création de la check box ne marche pas (message : méthode non gérée par l'objet). J'ai aussi essayé:

For Each Obj In ActiveSheet.OLEObjects
If TypeOf Obj.Object Is MSForms.CheckBox Then
Obj.Object.Value = True
End if
Next

...Sans plus de succès (Makach waloo).
Je vais voir comment contourner le pb mais si t'as déjà une idée sur le sujet elle est bien venue.

Merci encore pour ton aide, ça m'a bien débloqué!

Pour ceux que ça interesse, le code avec CB à la place de Ch (ça marche Nickel crôme) :

Sub Test()
Dim I As Integer
Dim F As Worksheet
Dim Code$

'Application.ScreenUpdating = False

Set F = ActiveSheet

F.OLEObjects.Delete
For I = 1 To 10
Code = "msgbox ""yoyo"" & " & I & ""
SupprUneProc ThisWorkbook, F.CodeName, "CB" & I & "_click"
AjouterUnObj F, "forms.checkbox.1", Array("CB" & I, F.Range("C" & I).Left + 3, F.Range("C" & I).Top + 3, 10, 10, "")
AjouterProcEven ThisWorkbook, F.CodeName, "Click", "CB" & I, Code
Next I
SendKeys "%{F11}" 'pour fermer VBE


'Application.ScreenUpdating = True

End Sub

Sub AjouterUnObj(F As Worksheet, Objet$, Optional T)
Dim B As OLEObject
Set B = F.OLEObjects.Add(Objet)
If IsMissing(T) Then Exit Sub
With B
.Name = T(0)
.Left = T(1)
.Top = T(2)
.Width = T(3)
.Height = T(4)
.Object.Caption = T(5)
'.Object.Value = True
End With
End Sub

Sub AjouterProcEven(C As Workbook, NomModule$, Evenement$, Objet$, Code$)
With C.VBProject.VBComponents(NomModule).CodeModule
.InsertLines .CreateEventProc(Evenement, Objet) + 1, Code
End With
End Sub

Sub SupprUneProc(C As Workbook, NomModule$, NomProc$)
On Error Resume Next
With C.VBProject.VBComponents(NomModule).CodeModule
.DeleteLines .ProcStartLine(NomProc, 0), .ProcCountLines(NomProc, 0)
End With
End Sub

 

[Zon]

Salut,

Pour les erreurs automation (N° 440) il faut rajouter une gestion d'erreurs, me demandes pas pourquoi c'est marqué dans l'aide sans trop de précision.

Sub AjouterUnObj(F As Worksheet, Objet$, Optional T)
Dim B As OLEObject
Set B = F.OLEObjects.Add(Objet)
If IsMissing(T) Then Exit Sub
With B
.Name = T(0)
.Left = T(1)
.Top = T(2)
.Width = T(3)
.Height = T(4)
.Object.Caption = T(5)
on error resume next '<===Ici
.Object.Value = True
End With
End Sub

Concernant ta boucle, l'écriture me semble bonne, peut être es tu en mode création ?

A+++

 

[Emeric]

Mille Merci Zon!

Tu assures grave!

J'ai inséré la ligne on error dans mon prog et ça marche nickel.

Je vais pouvoir maintenant me concentrer sur la logique de mon prog.

Et si d'ici là on se recontacte pas :

Bonne Année 2005!