Tester l'existence d'un objet shapes défini par son nom

[ROM1]

Bonjour,


Je souhaite créer une proédure (sub delet_picture) qui test l'esistence d'un objet shapes (en l'occurence, une image) dont le nom est défini par la variable pictnAMe as string).

sub delet_picture(pictnAme as string)
If ActiveSheet.Shapes(pictnAme) "EXISTE" then
ActiveSheet.Shapes(pictnAme).Delete
end if
end sub

Comment tester l'existence ActiveSheet.Shapes(pictnAme)?
Je n'est pas trouvé la propriété qui va bien 😱(

Merci

 

[Lord Nelson]

Salut Romain,

Tu peux essayer ceci :

Dim FA As Shape
For Each FA In Shapes
If FA.Name = PictName Then
FA.Delete
Exit For
End If
Next

Si ta variable PictName correspond bien à un nom de forme automatique, celle-ci sera détruite.

A+
Horatio

 

[ROM1]

thanks dear lord!

Je n'avais pas pensé à FOR EACH, mais entre temps j'ai trouvé cette solution (code ci dessous) qui bug quelquefois à cette instuction :
nOm = ActiveSheet.Shapes(j).Name
EREUR d'execution : l'index de cette instruction est en dehors des limites

=> for each devrait y remédier

voici le code, il permet de gérer l'affichage temporaire d'image. En fait on affiche une certaine quantité d'images au dessus et au dessous de la plage visible à l'écran. Quand on fait défiler (ici vers le bas avec flèche clavier), il arrive un moment ou on efface les images largement au dessus pour afficher les images au dessous.

=> ceci permet de maitriser la taille d'un fichier avec un grosse quantité d'images. Ca marche avec un fichier qui gère plus de 5000 images!



Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static PosI As Long
Dim Pt As Long
Dim M, N, H As Long
Dim i As Integer
Dim pictnAMe As String
Dim nOm As String



N = 10
M = 10
H = 5

'PosI = 2

Target.Select
ActiveWindow.ScrollRow = Target.Row
Pt = Target.Row
If Pt > PosI + N + H Then
ThisWorkbook.ActiveSheet.Select
ActiveSheet.Unprotect
Application.ScreenUpdating = False

For i = (Pt - (N + M)) To (Pt - N)
pictnAMe = "pict" & Range("d" & i).Value
xxx = ActiveSheet.Shapes.Count
For j = 1 To xxx - 7
'ActiveSheet.Shapes(j).Select
nOm = ActiveSheet.Shapes(j).Name
If nOm = pictnAMe Then
ActiveSheet.Shapes(j).Select
Selection.Delete
End If
Next j
Next i



For i = (Pt + H + M) To (Pt + H + M + N)
If Range("c" & i).Height > 0 Then
prionumber = Range("D" & i).Value
TestInsertPictureInrange prionumber, i

End If
Next i
PosI = Pt
End If

 

[ROM1]

Bonjour,

Avec le code ci dessous ça marche très très bien

😱) merci Lord Nelson


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static PosI As Long
Dim Pt As Long
Dim M, N, H As Long
Dim i As Integer
Dim pictnAMe As String
Dim nOm As String
Dim FA As Shape


N = 10
M = 10
H = 5

'PosI = 2

Target.Select
ActiveWindow.ScrollRow = Target.Row
Pt = Target.Row
If Pt > PosI + N + H Then
ThisWorkbook.ActiveSheet.Select
ActiveSheet.Unprotect
Application.ScreenUpdating = False

For i = (Pt - (N + M)) To (Pt - N)
pictnAMe = "pict" & Range("d" & i).Value
xxx = ActiveSheet.Shapes.Count
For Each FA In Shapes
If FA.Name = pictnAMe Then
FA.Delete
Exit For
End If
Next
'For j = 1 To xxx - 7
'ActiveSheet.Shapes(j).Select
' nOm = ActiveSheet.Shapes(j).Name
' If nOm = pictnAMe Then
' ActiveSheet.Shapes(j).Select
' Selection.Delete
'End If
'Next j
Next i



For i = (Pt + H + M) To (Pt + H + M + N)
If Range("c" & i).Height > 0 Then
prionumber = Range("D" & i).Value
TestInsertPictureInrange prionumber, i

End If
Next i
PosI = Pt
End If
End Sub