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

**StandManMike** · 03/02/2012, 18h55

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 :

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
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 :

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

 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

**mercatog** · 03/02/2012, 21h28

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

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
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

**StandManMike** · 04/02/2012, 11h19

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 !

**mercatog** · 04/02/2012, 12h28

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.

**StandManMike** · 04/02/2012, 15h02

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

c'est à ne rien y comprendre ! ... là j'avoue etre depassé

**mercatog** · 04/02/2012, 15h25

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?

Lecture de la propriété add de la classe buttons [XL-2003]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager