[VBA-E]Effacer les shapes

Version imprimable

09/06/2006, 14h18
tinmarbusir

[VBA-E]Effacer les shapes
:salut:
Un bug d'Excel m'ennuie un peu!(j'espère que c'est plutôt une erreur de ma part!

Un programme me crée des shapes,jusque là tout va bien
à chaque fois que je le relance j'efface les shapes de la feuille histoire que ce soi t un peu plus clair...
Code:

1 2 3 4 5 Dim forme As Shape For Each forme In Worksheets("feuil4").Shapes forme.Delete Next forme
Quand je le lance j'obtiens l'erreur
La méthode 'Delete' de l'objet 'Shape' a échoué
suivi du

Citation:

Microsoft Excel a rencontré un problème et doit fermer. Nous vous prions de nous excuser pour le désagrément encouru.
les infomations sur lesquelles vous travailliez peuvent avoir été perdues.
Microsoft Excel peut tenter de les récupérer
...........

Ah j'oubliai un détail intéressant.Quand j'utilise le débogueur(Pas à pas détaillé), il n'y a pas de problème...

Quelqu'un aurait il une explication si vou plééé???:calim2:
09/06/2006, 16h07
Catbull

Ca m'a l'air en effet d'être un bug. Chez moi ce code fonctionne très bien (Excel 2000 SP3).

Peut-être que le classeur n'est plus intégre. Essaie de copier les feuilles de ton classeur dans un autre classeur ainsi que les macros pour voir si le problème persiste.
09/06/2006, 18h12
zazaraignée
Salut

T'as essayé dans un compte à rebours?
Code:

1 2 3 4 Dim i As Integer For i = Feuil14.Shapes.Count to 1 Step -1 Shapes(i).Delete Next
[Edit] Apparemment, les indices des Shapes commencent à 1... 8O
09/06/2006, 18h39
SfJ5Rpw8
essai de voir quel "shape" provoque ton plantage ..:
Code:

1 2 3 4 5 6 7 8 Dim forme As Shape For Each forme In Worksheets("feuil4").Shapes Debug.Print forme.Name Debug.Print forme.Type Stop forme.Delete Next forme
le code s'arrête sur l'instruction Stop ... , observe le résultat dans fenêtre exécution, puis actionne F5 pour détruire le shape en cours.. ..
12/06/2006, 09h44
tinmarbusir
Salut
Après un bon week-end à la campagne, je suis retourné à ce:furieux: problème de "shapes". Je vous remercie tout d'abord pour vos réponses...
Code:

1 2 3 4 5 6 7 Dim Ftriangle As Shape For Each Ftriangle In Worksheets("feuil4").Shapes Debug.Print "nom :" & Ftriangle.Name; " - Type : " & Ftriangle.Type Stop Ftriangle.Delete Next Ftriangle
Avec ce code, il n'y a bizzarement pas d'erreur.(Comme avec le pas à pas)
En enlevant le Stop aussi...
Mais en enlevant la ligne debug.print, et bin çà marche encore
Ah bah non çà marche plus...:arf: (en clair çà marche nickel en pas à pas ou avec le stop sinon çà plante)

Je viens de remarquer autre chose. Quand je lance la macro depuis la feuille ou se trouve les données, l'éxécution trouve la même erreur mais ne plante pas...Elle plante quand je resélectionne la feuille des formes (la "feuil4")...
En revanche, quand la feuille ou sont dessinées mes formes est sélectionnée(des triangles en l'occurence), je me retrouve avec l'erreur...

:ouin: pourquoi VBA il est pas gentil avec moiiii?:ouin:
12/06/2006, 13h24
Ania

Juste comme ca parce que j'ai eu le cas une fois

est-ce la feuille ou tu supprime les shape est active ou du moins visible quand tu lance ta fonction?
12/06/2006, 15h15
tinmarbusir

bah çà dépend..
Quand elle est visible et là çà plante tout le temps
Quand elle n'est pas visible des fois çà ce passe bien des fois j'ai le message d'erreur. Et Excel plante ensuite quand je rend la feuille des triangles actives...
12/06/2006, 15h24
zazaraignée

Citation:

Envoyé par Ania

Juste comme ca parce que j'ai eu le cas une fois

est-ce la feuille ou tu supprime les shape est active ou du moins visible quand tu lance ta fonction?

+1

Essaie d'appeler ta shape d'abord par la feuille où elle est

Code:

Feuil14.Shapes("Ftriangle").Delete

Code:

1
2
3
4
5
6
For Each Ftriangle In Worksheets("feuil4").Shapes
   ville = ville + 1
   Debug.Print "nom :" & Ftriangle.Name; " - Type : " & Ftriangle.Type
'   Stop
   Ftriangle.Delete
Next Ftriangle

Yo c'est bien chaque triangle de la feuille "feuil4" qui est concernée non?:roll:

12/06/2006, 16h09
zazaraignée
Bon, mouais! en effet!

Alors, je re-pose ma question:
T'as essayé dans un compte à rebours?
Code:

1 2 3 4 Dim i As Integer For i = Feuil14.Shapes.Count to 1 Step -1 Shapes(i).Delete Next
12/06/2006, 16h27
tinmarbusir
:scarymov: Je suppose que tu voulais dire
Code:

1 2 3 4 Dim i As Integer For i = Worksheets("Feuil4").Shapes.Count To 1 Step -1 Worksheets("Feuil4").Shapes(i).Delete Next
Le code fonctionne avec le débogueur
mais en éxécution çà plante aussi. La seule différence est que l'erreur

Citation:

La méthode 'Delete' de l'objet 'Shape' a échoué

n'apparait plus (bah ouai y'a plus d'objet shape!)

Merci quand même!
zarma je désespère j'en ai marre de devoir effacer 40 formes une par une avant d'éxécuter!!!On s'habitue tellement vite aux macros...

J'ai un p'tit bout de code que j'ai utilisé pour supprimer des images.
peut etre que ca pourra vous aider.
Code:

1 2 3 4 5 6 7 8 9 Sub EffaceImage() Sheets("Devis").Select On Error Resume Next For i = 400 To 460 ActiveSheet.Shapes("Image " & i).Delete ActiveSheet.Shapes("Groupe " & i).Delete Next i On Error GoTo 0 End Sub
bonne continuation :)

13/06/2006, 09h25
tinmarbusir

C'est gentil mais à chaque fois mes formes prennent un nom différent... En fait je crèe plusieurs formes que je fusionne progressivement. Pour arriver à 20-25 formes à la fin.
Par contre je n'avais pas pensé àutiliser la gestion d'erreur. Est ce qu'elle pourrait mêtre utile pour éviter le plantage d'Excel? Je ne me souviens plus e la syntaxe de la gestion d'erreur...
13/06/2006, 10h13
Ania

ok

dans ce cas peux tu nommer tes shapes ou du moins les renommer c'est ce que j'avais fait.
Car je souhaitais conserver certaines images et pas d'autres, toutes mes images ayant un n° supérieur à 400 étaient supprimer, mais moi je faisais une copie d'image et non une création

bon courage ++
13/06/2006, 10h19
tinmarbusir

En fait j'ai déjà essayé de les renommer mais un nouveau nom est attribué automatiquement à chaque "groupement" de deux formes...
et étant donné qu'il y a une 20 de formes groupées ensemble à chaque fois et que je les rajoute une par une.Il faut renommer à chaque fois
13/06/2006, 14h07
Ania

dans ce cas ne peux tu pas renommer seulement le dernier groupe créer si tu connais le nombre de shapes que tu dois créer
13/06/2006, 14h56
zazaraignée
Citation:

Envoyé par tinmarbusir

C'est gentil mais à chaque fois mes formes prennent un nom différent... En fait je crèe plusieurs formes que je fusionne progressivement. Pour arriver à 20-25 formes à la fin.
Par contre je n'avais pas pensé àutiliser la gestion d'erreur. Est ce qu'elle pourrait mêtre utile pour éviter le plantage d'Excel? Je ne me souviens plus e la syntaxe de la gestion d'erreur...

Et c'est maintenant que tu songes à nous dire qu'il y avait des regroupements

Avant de me taper sur le crane à coup de marteau, l'ami, songe à nous dire la totale de tes manip sur les shapes.

Et les dégrouper avant de les effacer... t'as songé?

[Edit] avec excuses... le dégroupement est à oublier...
Ceci dit, J'ai testé chez mois différentes formes, groupées et pas groupées, j'ai effacé avec une petite macro nommée toto:
Code:

1 2 3 4 5 6 Sub toto() Dim forme As Shape For Each forme In Feuil1.Shapes forme.Delete Next End Sub
et toto marche à tous les coups. Alors questions:
- Combien de niveaux de groupements as-tu?
- Renommes-tu tes shapes et tes groupes à la main (ou par code)? Si oui, comment? (propriété Name...?)
- Y a-t-il un autre truc que tu as omis dans tes explications?

J'aurai peut-être du commencer par vous monter mon code...
les procédures Sub triangle_diachronique() et Sub triangle_synchronique() appelent les procédures Triangle et ajouter_point...

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
Option Explicit
Const Ltxt = 35
Const Htxt = 26.5
Const ColPct1 = 15 'Colonne Proportion de Hapax
Const ColPct2 = 19 'Poids des trois principaux patronymes
 
'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
Sub triangle_diachronique()
'1 triangle par ville, 1 point par periode
Dim pct(1 To 3) As Double
Dim ligne As Integer, ville As Integer, periode As Integer
Dim Ftriangle As Shape, Forme1 As Shape
Dim text As String
 
'ville = 0
'For Each Ftriangle In Worksheets("feuil4").Shapes
'   ville = ville + 1
'   Debug.Print "nom :" & Ftriangle.Name; " - Type : " & Ftriangle.Type; " -Numero : " & ville
'   Stop
'   Ftriangle.Delete
'Next Ftriangle
Dim i As Integer
For i = Worksheets("Feuil4").Shapes.Count To 1 Step -1
    Worksheets("Feuil4").Shapes(i).Delete
Next
 
ville = 0
For ligne = 2 To 101
   pct(1) = Sheets("feuil1").Cells(ligne, 15).Value
   pct(2) = Sheets("feuil1").Cells(ligne, 19)
   pct(3) = 1 - (pct(1) + pct(2))
   If ligne Mod 4 = 2 Then
      ville = ville + 1
      text = "Ville :" & Application.WorksheetFunction.VLookup(ville, Worksheets("Feuil1").Range("A105:D129"), 2)
      Call Triangle(Ftriangle, pct, ville, "Feuil4", text)
      periode = 0
   End If
   periode = periode + 1
   Call ajouter_point(Ftriangle, pct, periode)
Next ligne
End Sub
 
'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
Sub triangle_synchronique()
'1 triangle par periode, 1 point par région
Dim pct(1 To 3) As Double
Dim ligne As Integer, periode As Integer, region As Integer
Dim Ftriangle As Shape
Dim text As String
 
'on efface tout
For Each Ftriangle In Worksheets("Feuil triangle2").Shapes
   Debug.Print "nom :" & Ftriangle.Name; " - Type : " & Ftriangle.Type
   'Stop
   Ftriangle.Delete
Next Ftriangle
 
 
periode = 0
For ligne = 2 To 21
   pct(1) = Sheets("Feuil Microregion").Cells(ligne, 3).Value 'les coordonnées du point
   pct(2) = Sheets("Feuil Microregion").Cells(ligne, 4).Value
   pct(3) = 1 - (pct(1) + pct(2))
   If ligne Mod 5 = 2 Then 'un nouveau triangle
      periode = periode + 1
      region = 0
      text = "Periode n°" & periode
      Call Triangle(Ftriangle, pct, periode, "Feuil triangle2", text)
   End If
   region = region + 1
   Call ajouter_point(Ftriangle, pct, region)
Next ligne
End Sub

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
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
 
'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
Sub Triangle(Ftriangle As Shape, pct() As Double, No As Integer, NomFeuille As String, text As String)
 
Const Largeur = 150
Const Hauteur = ((3 / 4) * (Largeur ^ 2)) ^ (1 / 2) 'Pour que le triangle soit équilatéral
 
Dim Feuille As Worksheet
 
Dim lineL As Double, lineT As Double, LineW As Double, LineH As Double
Dim Coin1G As Double, coin1H As Double, Coin2G As Double, Coin2H As Double
Dim Forme1 As Shape, Forme2 As Shape
 
 
'coin en haut à gauche
Coin1G = Ltxt + (Largeur + Ltxt * 2) * ((No - 1) Mod 4)
coin1H = Htxt + (Hauteur + Htxt * 2) * (1 + Fix((No - 1) / 4))
'coin en bas à gauche
Coin2G = Coin1G
Coin2H = coin1H + Hauteur
 
Set Feuille = ThisWorkbook.Worksheets(NomFeuille)
 
 
Set Forme1 = _
Feuille.Shapes.AddShape(msoShapeRectangle, _
Coin1G, coin1H, Largeur, Hauteur) 'le rectange
Set Forme2 = _
Feuille.Shapes.AddShape(msoShapeIsoscelesTriangle, _
Coin1G, coin1H, Largeur, Hauteur) 'le triangle
 
Set Ftriangle = Feuille.Shapes.Range(Array(Forme1.Name, Forme2.Name)).Group
'on fusionne les 2 formes
 
'Pour le 1° %
'-----------------------------------------------
lineL = Coin1G + Largeur * pct(1)
lineT = Coin2H
LineW = lineL + Largeur * (1 - pct(1)) / 2
LineH = lineT + Hauteur * (pct(1) - 1)
Set Forme1 = Feuille.Shapes.AddLine(lineL, lineT, LineW, LineH)
Forme1.Line.ForeColor.RGB = RGB(120, 225, 34)
Set Ftriangle = Feuille.Shapes.Range(Array(Forme1.Name, Ftriangle.Name)).Group
 
Set Forme1 = Feuille.Shapes.AddTextbox(msoTextOrientationHorizontal, Coin2G, Coin2H, Ltxt, Htxt)
Call legende_ligne(Forme1, "0", 1)
Set Ftriangle = Feuille.Shapes.Range(Array(Forme1.Name, Ftriangle.Name)).Group
 
Set Forme1 = Feuille.Shapes.AddTextbox(msoTextOrientationHorizontal, Coin2G + Largeur, Coin2H, Ltxt, Htxt)
Call legende_ligne(Forme1, "100%", 1)
Set Ftriangle = Feuille.Shapes.Range(Array(Forme1.Name, Ftriangle.Name)).Group
 
 
'Pour le 2° %
'------------------------------------
lineL = Coin1G + Largeur * pct(2) / 2
lineT = coin1H + Hauteur * (1 - pct(2))
LineW = lineL + Largeur * (1 - pct(2))
LineH = lineT
Set Forme1 = Feuille.Shapes.AddLine(lineL, lineT, LineW, LineH)
Forme1.Line.ForeColor.RGB = RGB(43, 101, 226)
Set Ftriangle = Feuille.Shapes.Range(Array(Forme1.Name, Ftriangle.Name)).Group
 
 
Set Forme1 = Feuille.Shapes.AddTextbox(msoTextOrientationHorizontal, Coin2G + Largeur, Coin2H - Htxt, Ltxt, Htxt)
Call legende_ligne(Forme1, "0", 2)
Set Ftriangle = Feuille.Shapes.Range(Array(Forme1.Name, Ftriangle.Name)).Group
 
Set Forme1 = Feuille.Shapes.AddTextbox(msoTextOrientationHorizontal, Coin1G + Largeur / 2, coin1H, Ltxt, Htxt)
Call legende_ligne(Forme1, "100%", 2)
Set Ftriangle = Feuille.Shapes.Range(Array(Forme1.Name, Ftriangle.Name)).Group
 
'Pour le 3° %
'--------------------------------------------------------
lineL = Coin1G + Largeur * (1 - pct(3)) / 2
lineT = coin1H + Hauteur * pct(3)
LineW = Coin2G + Largeur * (1 - pct(3))
LineH = Coin2H
Set Forme1 = Feuille.Shapes.AddLine(lineL, lineT, LineW, LineH)
Forme1.Line.ForeColor.RGB = RGB(120, 0, 255)
Set Ftriangle = Feuille.Shapes.Range(Array(Forme1.Name, Ftriangle.Name)).Group
 
Set Forme1 = Feuille.Shapes.AddTextbox(msoTextOrientationHorizontal, Coin1G + Largeur / 2 - Ltxt, coin1H, Ltxt, Htxt)
Call legende_ligne(Forme1, "0", 3)
Set Ftriangle = Feuille.Shapes.Range(Array(Forme1.Name, Ftriangle.Name)).Group
 
Set Forme1 = Feuille.Shapes.AddTextbox(msoTextOrientationHorizontal, Coin2G, Coin2H - Ltxt, Ltxt, Htxt)
Call legende_ligne(Forme1, "100%", 3)
Set Ftriangle = Feuille.Shapes.Range(Array(Forme1.Name, Ftriangle.Name)).Group
 
            '--------------------------------------------
'La zone de texte associée au triangle
Set Forme1 = Feuille.Shapes.AddTextbox(msoTextOrientationHorizontal, Coin1G, coin1H - Htxt, Largeur, Htxt)
Forme1.TextFrame.Characters.text = text
Set Ftriangle = Feuille.Shapes.Range(Array(Forme1.Name, Ftriangle.Name)).Group
 
 
End Sub
 
 
'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
Sub legende_ligne(forme As Shape, text As String, No As Integer)
'Pour mettre en forme une forme
With forme
   .TextFrame.Characters.text = text
   .TextFrame.AutoSize = True
   Select Case No
      Case 1:     .TextFrame.Characters.Font.Color = RGB(120, 225, 34)
      Case 2:     .TextFrame.Characters.Font.Color = RGB(43, 101, 226)
      Case 3:     .TextFrame.Characters.Font.Color = RGB(120, 120, 120)
      Case 4:     .TextFrame.Characters.Font.Color = RGB(255, 0, 255)
      Case Else:  .TextFrame.Characters.Font.Color = RGB(20, 20, 34)
   End Select
   .Fill.Visible = msoFalse
   .Line.Visible = msoFalse
End With
End Sub
 
'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
Sub ajouter_point(Ftriangle As Shape, pct() As Double, noPoint As Integer)
Const TaillePt = 5
Dim lineL As Double, lineT As Double
Dim Point As Shape
Dim Feuille As Worksheet
Dim Nocouleur As Long
 
'la couleur du point
Select Case noPoint
   Case 1: Nocouleur = RGB(120, 225, 34)
   Case 2: Nocouleur = RGB(43, 101, 226)
   Case 3: Nocouleur = RGB(120, 120, 120)
   Case 4: Nocouleur = RGB(255, 0, 255)
   Case Else: Nocouleur = RGB(20, 20, 34)
End Select
 
Set Feuille = Worksheets(Ftriangle.TopLeftCell.Worksheet.Name)
'la feuille de la forme du triangle
 
'Ses coordonnées
lineL = Ftriangle.Left + (Ftriangle.Width - Ltxt) * ((pct(2) / 2) + pct(1))
lineT = Ftriangle.Top + Htxt + (Ftriangle.Height - 2 * Htxt) * (1 - pct(2))
 
'on le crèe et le met en forme
Set Point = Feuille.Shapes.AddShape(msoShapeOval, lineL - TaillePt / 2, lineT + TaillePt / 2, TaillePt, TaillePt)
Point.Line.Weight = TaillePt
Point.Line.ForeColor.RGB = Nocouleur
Point.Line.BackColor.RGB = Nocouleur
Set Ftriangle = Feuille.Shapes.Range(Array(Point.Name, Ftriangle.Name)).Group
 
'La légende
lineL = Ftriangle.Left
lineT = Ftriangle.Top + Htxt * ((noPoint + 1) / 2)
Set Point = Feuille.Shapes.AddTextbox(msoTextOrientationHorizontal, lineL, lineT, TaillePt, TaillePt)
Call legende_ligne(Point, CStr(noPoint), noPoint)
Point.TextFrame.Characters.Font.Bold = True
Set Ftriangle = Feuille.Shapes.Range(Array(Point.Name, Ftriangle.Name)).Group
End Sub

14/06/2006, 13h33
zazaraignée

Je dois débrancher l'ordi pour un déménagement...
Je passe la main.

Bonne chance.

À bientôt.