Lecture de la propriété add de la classe buttons

Version imprimable

Bonsoir

je me trouve devant un petit soucis que je n'ai reussi à résoudre ayant pourtant bien recherché , je dispose d'une macro me permettant de copier des feuilles et sur ces feuilles je souhaites ajouter des boutons de formulaire

voici le code :

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
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
    Sub transfertfret()
 
        Dim TRANSITION As Workbook
        Dim ws As Worksheet
        Dim xcell As Range
        Dim chemin As String
        Dim fichier As String
        Dim S As Shape
        chemin = ThisWorkbook.Path
 
        ' A est le classeur sur lequel je me trouve pour executer le code
 
 
        'jouvre le classeur B :
      Workbooks.Open Filename:=chemin & "\B.xls"
       Workbooks("A.xls").Unprotect Password:="start"
       Workbooks.Open Filename:=chemin & "\TRANSITION.xls"
       Workbooks("TRANSITION.xls").Unprotect Password:="start"
 
        'j'effectue une comparaison entre les feuilles du classeur B et la plage b21:b100 feuille 1 du classeur A :
      For Each xcell In Workbooks("A").Sheets("Feuil1").Range("C21:C100")
 
 
 
          For Each ws In Workbooks("B").Worksheets
 
                If xcell = ws.Name Then
 
 
 
                    Set TRANSITION = Workbooks("TRANSITION.xls")
 
 
                   ws.Copy after:=TRANSITION.Sheets(TRANSITION.Sheets.Count)
                   With Workbooks("TRANSITION.xls")
                   For Each S In ActiveSheet.Shapes
                   S.Delete
                    Next S
                    End With
 
 
                 '**************************************************************************************************************************************
       With Workbooks("TRANSITION.xls").ActiveSheet.Buttons.Add(Range("H155:I156").Left, Range("H155:I156").Top, Range("H155:I156").Width, Range("H155:I156").Height)
            '.Select
          .Characters.Text = "IMPRIMER"
 
           .OnAction = " 'TRANSITION.xls'!IMPRESSION"
            With .Characters(Start:=1, Length:=23).Font
                .Name = "Arial"
                .FontStyle = "Normal"
                .Size = 22
                .ColorIndex = xlAutomatic
            End With
       End With
        '*************************************************************************************************************************************************
       With Workbooks("TRANSITION.xls").ActiveSheet.Buttons.Add(Range("c155:B156").Left, Range("c155:B156").Top, Range("c155:B156").Width, Range("c155:B156").Height)
            '.Select
          .Characters.Text = "QUITTER"
            .OnAction = " 'TRANSITION.xls'!QUITTER"
            With .Characters(Start:=1, Length:=7).Font
                .Name = "Arial"
                .FontStyle = "Normal"
                .Size = 20
                .ColorIndex = xlAutomatic
            End With
        End With
        '*********************************************************************************************************************************************
       With Workbooks("TRANSITION.xls").ActiveSheet.Buttons.Add(Range("E155:F156").Left, Range("E155:F156").Top, Range("E155:F156").Width, Range("E155:F156").Height)
            '.Select
          .Characters.Text = "SORTANT"
            .OnAction = " 'TRANSITION.xls'!REVENIR1"
            With .Characters(Start:=1, Length:=7).Font
                .Name = "Arial"
                .FontStyle = "Normal"
                .Size = 20
                .ColorIndex = xlAutomatic
            End With
       End With
        '**********************************************************************************************************************************************
       With Workbooks("TRANSITION.xls").ActiveSheet.Buttons.Add(Range("L155:K156").Left, Range("L155:K156").Top, Range("L155:K156").Width, Range("L155:K156").Height)
            '.Select
          .Characters.Text = "MESURE"
            .OnAction = " 'TRANSITION.xls'!evaluation"
            With .Characters(Start:=1, Length:=7).Font
                .Name = "Arial"
                .FontStyle = "Normal"
                .Size = 20
                .ColorIndex = xlAutomatic
            End With
        End With
 
                End If
 
            Next ws
 
        Next xcell
 
        'enregistre les modifs
    Workbooks("TRANSITION.xls").Protect Password:="start"
 
       Workbooks("TRANSITION.xls").Close True
 
    Workbooks("B.xls").Protect Password:="start"
        Workbooks("B.xls").Close True
 
    End Sub

j'ai un bug à la ligne :

Code:

 With Workbooks("TRANSITION.xls").ActiveSheet.Buttons.Add(Range("E155:F156").Left, Range("E155:F156").Top, Range("E155:F156").Width, Range("E155:F156").Height)

avec l'information "impossible de lire la propriété add de la classe buttons

En vous remerciant pour tout conseil utile , car je n'ai pas réussi à résoudre ce probleme

Cordialement

Utilise plutôt des variables objets pour pouvoir arriver au résultat.
Exemple

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
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
Sub TransfertFret()
Dim WbkB As Workbook, WbkT As Workbook
Dim WsB As Worksheet, WsT As Worksheet
Dim Chemin As String
Dim xCell As Range
Dim S As Shape
 
Chemin = ThisWorkbook.Path
'jouvre le classeur B :
Set WbkB = Workbooks.Open(Chemin & "\B.xls")
WbkB.Unprotect Password:="start"
Set WbkT = Workbooks.Open(Chemin & "\TRANSITION.xls")
WbkT.Unprotect Password:="start"
 
'j'effectue une comparaison entre les feuilles du classeur B et la plage b21:b100 feuille 1 du classeur A :
For Each xCell In ThisWorkbook.Sheets("Feuil1").Range("C21:C100")
    For Each WsB In WbkB.Worksheets
        If xCell = WsB.Name Then
            WsB.Copy after:=WbkT.Sheets(WbkT.Sheets.Count)
            Set WsT = WbkT.Sheets(WbkT.Sheets.Count)
            With WsT
                For Each S In .Shapes
                    S.Delete
                Next S
                '**************************************************************************************************************************************
                With .Buttons.Add(.Range("H155").Left, .Range("H155").Top, .Range("H155:I155").Width, .Range("H155:H156").Height)
                    .Characters.Text = "IMPRIMER"
                    .OnAction = " 'TRANSITION.xls'!IMPRESSION"
                    With .Characters(Start:=1, Length:=23).Font
                        .Name = "Arial"
                        .FontStyle = "Normal"
                        .Size = 22
                        .ColorIndex = xlAutomatic
                    End With
                End With
            End With
            '**************************************************************************************************************************************
            'les autres boutons (ou bien mettre une procédure générique qui a comme paramètres le Text, OnActions et position du bouton
            Set WsT = Nothing
        End If
    Next WsB
Next xCell
 
'enregistre les modifs
With WbkT
    .Protect Password:="start"
    .Close True
End With
Set WbkT = Nothing
 
WbkB.Close False
Set WbkB = Nothing
End Sub

04/02/2012, 11h19
StandManMike

Merci pour cette réponse , ayant toutefois repris la correction que tu m'a proposé j'ai toujours le meme message d'erreur à la meme ligne !
04/02/2012, 12h28
mercatog

Ayant testé avec succès le code que j'avais proposé et ne voyant pas ton dernier code, je ne peux pas deviner la cause.
04/02/2012, 15h02
StandManMike

Mon code est tel que celui que j'ai donné , j'ai repris integralement votre

correction et j'ai toujours le meme message d'erreur :cry::cry::cry:

c'est à ne rien y comprendre ! ... là j'avoue etre depassé
04/02/2012, 15h25
mercatog

Si c'est pas trop te demander, il est souhaitable que tu reportes ici ton code tel que testé.
Peut être quelque chose t'as échappé lors de l'adaptation.
Sinon, qu'est ce que ta feuille a de spécial?

le voici mais rien de plus que votre adaptation :

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
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
Sub TransfertFret()
Dim WbkB As Workbook, WbkT As Workbook
Dim WsB As Worksheet, WsT As Worksheet
Dim Chemin As String
Dim xCell As Range
Dim S As Shape
 
Chemin = ThisWorkbook.Path
'jouvre le classeur B :
Set WbkB = Workbooks.Open(Chemin & "\B.xls")
WbkB.Unprotect Password:="start"
Set WbkT = Workbooks.Open(Chemin & "\TRANSITION.xls")
WbkT.Unprotect Password:="start"
 
'j'effectue une comparaison entre les feuilles du classeur B et la plage b21:b100 feuille 1 du classeur A :
For Each xCell In ThisWorkbook.Sheets("Feuil1").Range("C21:C100")
    For Each WsB In WbkB.Worksheets
        If xCell = WsB.Name Then
            WsB.Copy after:=WbkT.Sheets(WbkT.Sheets.Count)
            Set WsT = WbkT.Sheets(WbkT.Sheets.Count)
            With WsT
                For Each S In .Shapes
                    S.Delete
                Next S
                '**************************************************************************************************************************************
                With .Buttons.Add(.Range("H155").Left, .Range("H155").Top, .Range("H155:I155").Width, .Range("H155:H156").Height)
                    .Characters.Text = "IMPRIMER"
                    .OnAction = " 'TRANSITION.xls'!IMPRESSION"
                    With .Characters(Start:=1, Length:=23).Font
                        .Name = "Arial"
                        .FontStyle = "Normal"
                        .Size = 22
                        .ColorIndex = xlAutomatic
                    End With
                End With
            End With
            '**************************************************************************************************************************************
            'les autres boutons (ou bien mettre une procédure générique qui a comme paramètres le Text, OnActions et position du bouton
            Set WsT = Nothing
        End If
    Next WsB
Next xCell
 
'enregistre les modifs
With WbkT
    .Protect Password:="start"
    .Close True
End With
Set WbkT = Nothing
 
WbkB.Close False
Set WbkB = Nothing
End Sub

je me demande s'il n'y a pas eventuellement une option à activer dans excel pour que vba puisse lire la" proprieté add de la classe button"

et c'est toujours cette ligne qui bloque :

Code:

With .Buttons.Add(.Range("H155").Left, .Range("H155").Top, .Range("H155:I155").Width, .Range("H155:H156").Height)

04/02/2012, 16h25
mercatog

Au lieu de cette ligne, mets celle là

Code:

With .Buttons.Add(100, 200, 60,25)

Citation:

Sinon, qu'est ce que ta feuille a de spécial?
04/02/2012, 16h53
StandManMike
je pense que mon vba pète un cable !!!!!!!!!!!!!!!!8O8O8O8O8O8O

en attendant de tester ta dernière proposition , il vient d'arriver

une anomalie sur la ligne
Code:

1 2 3 For Each S In .Shapes S.Delete Next S
au niveau de

Code:

S.Delete

!!!! avec " ERREUR DEFINIE PAR L'APPLICATION OU PAR L'OBJET "

sa rend fou !!!!!!!!!!!!!!!!!!!!:calim2:
04/02/2012, 17h05
mercatog

Ta feuille est elle protégée?
04/02/2012, 17h12
StandManMike

oui ....:oops: cela jouerai en quoi ?
04/02/2012, 17h22
mercatog

Sur une feuille protégée, est ce que tu peux manuellement supprimer ou ajouter un bouton?
04/02/2012, 18h57
StandManMike

:lol::lol::lol::lol: je crois que j'y suis !! en tout cas je te remercie d'avoir suivit

mon probleme et merci encor pour les réponses que tu m'a apporté