Echec de la méthode Add de oleoobjects

Il plante lors de l'ajout du bouton. Voici le code

Etape 1 : Double clique dans une cellule ==> propose l'ajout de donnée

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 
    If Not Intersect(Target, Feuil1.Range("C7:C" & Feuil1.Range("B1048576").End(xlUp).Row + 1)) Is Nothing Then 'si double click dans la cellule correspondant au product code
        If (ActiveCell.Offset(columnOffset:=-1)) <> "" Then
            Select Case MsgBox("Souhaitez vous ajouter/remplacer des datas pour le point " & ActiveCell.Offset(columnOffset:=-1) & " ?", vbYesNo + vbQuestion, "Ajout data")
                Case vbYes
                    Call ajout
                Case vbNo
                    Exit Sub
            End Select
        End If
    End If
End Sub

Etape 2 =Ajoute les datas à partir d'un autre fichier

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Sub ajout() 'import du fichier étalon
 
    Dim File As String 'déclaration de variables
    Dim Fichier As Workbook
    Dim Lig As Long, Col As Long
 
    Lig = ActiveCell.Row
 
    File = strChooseFile("Indiquer le fichier de données", "Z:\3-MANUFACTURING\3-MANIP DATA\_" & Format(Date, "YYYY") & "\_PROD\") 'choix du fichier etalon par défaut
 
    If File = vbNullString Then
        Select Case MsgBox("Aucun fichier sélectionné", vbExclamation + vbOKOnly, "Pas de fichier sélectionné")
            Case vbOK
                Exit Sub
        End Select
    End If
 
    Set Fichier = Application.Workbooks.Open(File) 'ouvre le fichier
    Fichier.Sheets(1).Range("E2:S2").Copy Feuil1.Range("C" & Lig) 'Copie-colle le tableau récap étalon dans le fichier de calibration LAGRANGE
    Fichier.Close False 'ferme le fichier gestion des étalons sans sauvegarder
 
End Sub

Etape 3 ==> modification valeur de la feuille

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
26
Private Sub Worksheet_Change(ByVal Target As Range) 'se déclenche si l'on change une valeur de cellule (définie par Target)
 
    Dim i As Long, j As Long, c As Long 'Définition de variable
    Dim k As Integer
    Dim Obj  As OLEObject
    Dim Bool3 As Boolean
 
    If Not Intersect(Target, Feuil1.Range("C8:C" & Feuil1.Range("B1048576").End(xlUp).Row + 1)) Is Nothing Then
        j = Feuil1.Range("B1048576").End(xlUp).Row + 1 'recherche dernière ligne dans calibration data
        c = j
        k = Feuil2.Range("A3").End(xlDown).Row
        For Lig = 8 To j Step 1
            If Feuil1.Range("B" & Lig) = "Check" Then c = Lig
            Bool3 = False
            If Lig > c And Feuil1.Range("C" & Lig) <> "" Then
                For Each Obj In Feuil1.OLEObjects
                    If Obj.Name = "Check_" & Lig Then Bool3 = True 'si le nom du bouton est différent de MAJ alors on le supprime
                Next Obj
                If Bool3 = False Then
                    Set WB = ThisWorkbook
                    crcbx Lig, WB 'fonction ajout bouton
                End If
            End If
        Next Lig
    End If
End Sub

fonction d'ajout du bouton qui bloque !

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
26
27
28
29
30
31
32
33
34
Public Function crcbx(ByVal z As Integer, ByVal WKB As Workbook) 'fonction pour la création des boutons
 
    Dim X As Integer
 
    WKB.Activate
    Feuil1.Unprotect
 
    Set Obj = Feuil1.OLEObjects.Add("Forms.ToggleButton.1") 'ajout d'un bouton==> cette ligne crée une erreur
    Obj.Height =Feuil1.Range("A" & z).Height 'hauteur du bouton
    Obj.Width = Obj.Height 'largeur du bouton
    Obj.Left = Feuil1.Range("B" & z).Left - Obj.Width 'position du bouton horizontal
    Obj.Top = Feuil1.Range("A" & z).Top 'position du bouton vertical
    Obj.Object.BackColor = RGB(0, 255, 0) 'couleur du fond du bouton vert
    Obj.Object.Caption = "" 'valeur du texte
    Obj.Name = "Check_" & z 'nom du bouton
 
    With WKB.VBProject.VBComponents("Feuil1").CodeModule
        X = .CountOfLines
        .InsertLines X + 1, "Sub Check_" & z & "_Click()"
        .InsertLines X + 2, vbTab & "If Check_" & z & ".Value = True Then"
        .InsertLines X + 3, vbTab & vbTab & "Check_" & z & ".BackColor = RGB(255, 0, 0)"
        .InsertLines X + 4, vbTab & "Else"
        .InsertLines X + 5, vbTab & vbTab & "Check_" & z & ".BackColor = RGB(0,255, 0)"
        .InsertLines X + 6, vbTab & "End if"
        .InsertLines X + 7, "End Sub"
    End With
 
    Feuil1.Unprotect
    Feuil1.Range("A1:XFD1048576").Locked = True
    Feuil1.Range("B2,B3,G3,I3,J3,L3").Locked = False
    Feuil1.Range("B7:Y1048576").Locked = False
    Feuil1.Protect DrawingObjects:=False, Contents:=True, Scenarios:=False, UserInterfaceOnly:=True, AllowFormattingCells:=False, AllowFormattingColumns:=False, AllowFormattingRows:=False, AllowInsertingColumns:=False, AllowInsertingRows:=False, AllowInsertingHyperlinks:=False, AllowDeletingColumns:=False, AllowDeletingRows:=False, AllowSorting:=False, AllowFiltering:=False, AllowUsingPivotTables:=False
 
End Function

Je n'arrive pas à comprendre pourquoi il me jette !

Je pensais que c'était du fait qu'un autre était ouvert ou alors de la protection de la feuille. Mais je m'affranchis de ça avec set WB=thisworkbook et feuil1.unprotect. Des suggestions ?

Bonjour
as-tu pensé à vérifier combien vaut la variable lig lorsque tu appelles ta fonctions ? Déclarée en integer, tu auras un plantage si elle vaut plus que la valeur limite d'un integer !

Bonjour unparia,

Merci de ta réponse, j'ai effectivement vérifié Lig qui dépasse rarement la valeur de 20. J'ai fait retourner le code et il à l'air de fonctionner et parfois de planter. Du coup je pense à un conflit potentiel de variable du genre WB ou WKB mal défini. je vais essayer de retoiletter mon code pour le rendre plus sûr.