[XL-2007] Le code dynamiquement créé ne s'enregistre pas

[defluc]

Bonjour à tous,

Cela fait des jours que j'ai un problème aléatoire et que j'écume la toile pour trouver une solution.

Je crée dynamiquement un bouton et le code associé à l'événement OnClicK.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub PutControlErrorsBtn()
  Dim Obj As Object
  Dim Code As String
  ThisWorkbook.Sheets(1).Select
  Set Obj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False, DisplayAsIcon:=False, _
            Left:=0, Top:=0, Width:=180, Height:=24)
  Obj.Name = "ControlErrorsBtn"
  Obj.Object.Caption = "Recherche des erreurs d'extraction"
  Code = "Private Sub " & Obj.Name & "_Click()" & vbCrLf
  Code = Code & "  Constat2ExtractErrors" & vbCrLf
  Code = Code & "End Sub"
   With ThisWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
        .insertlines .CountOfLines + 1, Code
    End With
End Sub

Le bouton se crée mais parfois, le code ne s'enregistre pas, ce qui rend le bouton inutile.
J'ai essayé sur deux autres machines et, cela marche un jour, le lendemain plus. J'ai mis le code dans une boucle while testant la valeur zéro du nombre de lignes de code, rien à faire.

Quelqu'un aurait-il une solution pour s'assurer que le code est bien enregistré pour rendre mon application fiable ?

Merci d'avance

[mercatog]

Au lieu des Select et Activesheet

Code :

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
Sub PutControlErrorsBtn()
Dim Obj As OLEObject
Dim Sh As Worksheet
Dim Code As String, NomBouton As String
 
NomBouton = "ControlErrorsBtn"
Set Sh = ThisWorkbook.Sheets(1)
On Error Resume Next
Set Obj = Sh.OLEObjects(NomBouton)
On Error Resume Next
'On vérifie si notre bouton existe déjà
If Obj Is Nothing Then
    Set Obj = Sh.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False, DisplayAsIcon:=False, Left:=0, Top:=0, Width:=180, Height:=24)
    Obj.Name = NomBouton
    Obj.Object.Caption = "Recherche des erreurs d'extraction"
    Code = "Private Sub " & NomBouton & "_Click()" & vbCrLf
    Code = Code & "  Constat2ExtractErrors" & vbCrLf
    Code = Code & "End Sub"
    With ThisWorkbook.VBProject.VBComponents(Sh.CodeName).CodeModule
        .insertlines .CountOfLines + 1, Code
    End With
    Set Obj = Nothing
End If
Set Sh = Nothing
End Sub

[defluc]

Premier test : négatif

Enregistrement du classeur
Fermeture de Excel
Ouverture du classeur

Test positif.

Le problème ayant été aléatoire, il me reste à contrôler s'il n'apparait plus avant de clôturer le sujet.

Merci déjà à toi mercatog

[defluc]

Bon ben vla qu'ça recommence.

Mais qu'est-ce qui peut bien causer ce problème ?

Fermer Excel, rebooter, rien n'y fait.