Microsoft 365 supression image

luc50* · 8 Avril 2020

bonjour
débutant en vba je cherche a sélectionner un plage donne et a supprimer les images quelle contient mais sa bloque dan ma formule

For Each s In ActiveSheet.Shapes
If Not Intersect(s.TopLeftCell,Range("$B$149:$Q191")) Is Nothing Then s.delete
Next s

Staple1600 · 10 Avril 2020

Re

Et en bonus, un macro pour supprimer les six images d'un coup
(test OK sur mon PC)

VB:

Sub Delete_All_Imgs()
Dim supprIMG, i As Byte
On Error Resume Next
supprIMG = Array("C149:H160", "K149:O160", "C162:H174", "K162:O174", "C176:H188", "K176:O188")
For i = LBound(supprIMG) To UBound(supprIMG)
ActiveSheet.Shapes("img" & supprIMG(i)).Delete
Next
End Sub

Staple1600 · 8 Avril 2020

Bonjour

test ok chez moi

VB:

Sub Test()
Dim s As Shape
For Each s In ActiveSheet.Shapes
If Not Intersect(s.TopLeftCell, Range("$B$149:$Q191")) Is Nothing Then
MsgBox s.TopLeftCell.Offset.Address 'pour test
s.Delete
End If
Next s
End Sub

NB: Le MsgBox s'est juste pour être sur qu'il y a bien des images en colonne B.
A supprimer ensuite.

luc50* · 9 Avril 2020

bonjour et merci pour votre aide
mais chez moi cette macro fonctionne quand je prend une feuiile excell vierge
mais pas sur ma feuille qui contient déjà pas mal de macro

Staple1600 · 9 Avril 2020

Bonjour

C'est sans doute parce que tes images ne sont pas en colonne B sur ton vrai fichier.

luc50* · 10 Avril 2020

Bonjour
la photo est mise automatiquement a cet emplacement grâce a la macro suivante:
Sub image1()

Range("C149:H160").Select

Dim ficimg As String, Ad As String
Ad = Selection.Address
ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix du fichier
If ficimg = Faux Then Exit Sub
Set Image = ActiveSheet.Shapes.AddPicture(ficimg, False, True, ActiveCell.Left, ActiveCell.Top, Range(Ad).Width, Range(Ad).Height)
With Image
.LockAspectRatio = False 'proportions d'origine lorsque vous la redimensionnez
.Placement = xlMoveAndSize
End With
End Sub

et après dans ma macro d’effacement je reprend les même cellules ("C149:H160")

Staple1600 · 10 Avril 2020

Bonjour le fil, luc50

*Réutilises la macro Test (en supprimant la ligne s.Delete
Qu'affiche alors les MsgBox?

*: Juste pour faire un test et chercher à comprendre pourquoi ce ne fonctionne pas sur ton vrai fichier.

luc50* · 10 Avril 2020

Bonjour stapple1600
la msgbox me dit
$C$150

Staple1600 · 10 Avril 2020

RE

Fais ce test, sur une feuille vide
1) Lance la macro Créer_TEST
2) Lance ensuite la macro: Test_II

VB:

Sub Créer_TEST()
Dim i%, shp As Shape
ActiveSheet.DrawingObjects.Delete
For i = 1 To 10
Set shp = ActiveSheet.Shapes.AddShape(78 + i, 2 + (i * 75), 80, 53.25, 46.5)
shp.BackgroundStyle = 1 + i
shp.Fill.ForeColor.RGB = RGB(255, 255 - (i * 11), 0)
Next
End Sub
Sub Test_II()
Dim s As Shape
For Each s In ActiveSheet.Shapes
If Not Intersect(s.TopLeftCell, Range("B:G")) Is Nothing Then
s.Delete
End If
Next s
End Sub

Seules les "images" en colonnes B:G seront effacées.
(En tout cas, c'est le cas sur mon PC.)

patricktoulon · 10 Avril 2020

bonjour

les select ou autre activate on peut s'en passer
quand on insert une shape/picture on la nomme
et si cette shape doit être en corrélation avec une plageon la nomme en corrélation avec la plage

conclusion

VB:

Sub image1()
    Dim ficimg As String, image As Shape, Rng As Range
   Set Rng = Range("C149:H160")
     ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image")    ' choix du fichier
    If ficimg = Faux Then Exit Sub
    Set image = ActiveSheet.Shapes.AddPicture(ficimg, False, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
    With image
        .Name = "img" & Rng.Address(0, 0)
        .LockAspectRatio = False    'proportions d'origine lorsque vous la redimensionnez(faux!!!!!!!)
        .Placement = xlMoveAndSize
    End With
End Sub
'
'
'
Sub supprime_image()
    Dim Rng As Range, shp As Shape
    Set Rng = Range("C149:H160")
    Set shp = ActiveSheet.Shapes("img" & Rng.Address(0, 0))
    If Not shp Is Nothing Then shp.Delete
End Sub

bonne route 😉

Staple1600 · 10 Avril 2020

Bonjour aussi à toi patricktoulon... 🙄

NB: Pas vu de select, ou d'activate dans mon code...

Et cela n'explique pas pourquoi le test fonctionne mais pas le même code sur le fichier du demandeur.

luc50* · 10 Avril 2020

Bonjour0 vous deux et encore merci pour vos idées
la solution de paticktoulon fonctionne parfaitement j'arrive a mettre mes six phots au emplacements prévu par contre effacement rencontre un bug des que l'emplacement de mes photos et vide
MACRO POUR METTRE AFFICHE JUSQU’À SIX PHOTOS

(chaque macro est relie a un bouton différent)

Sub NEWIMAG1()
Dim ficimg As String, image As Shape, Rng As Range
Set Rng = Range("C149:H160")
ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix du fichier
If ficimg = Faux Then Exit Sub
Set image = ActiveSheet.Shapes.AddPicture(ficimg, False, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
With image
.Name = "img" & Rng.Address(0, 0)
.LockAspectRatio = False 'proportions d'origine lorsque vous la redimensionnez(faux!!!!!!!)
.Placement = xlMoveAndSize
End With
End Sub

Sub NEWIMG2()
Dim ficimg As String, image As Shape, Rng As Range
Set Rng = Range("K149:O160")
ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix du fichier
If ficimg = Faux Then Exit Sub
Set image = ActiveSheet.Shapes.AddPicture(ficimg, False, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
With image
.Name = "img" & Rng.Address(0, 0)
.LockAspectRatio = False 'proportions d'origine lorsque vous la redimensionnez(faux!!!!!!!)
.Placement = xlMoveAndSize
End With
End Sub

Sub NEWIMG3()
Dim ficimg As String, image As Shape, Rng As Range
Set Rng = Range("C162:H174")
ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix du fichier
If ficimg = Faux Then Exit Sub
Set image = ActiveSheet.Shapes.AddPicture(ficimg, False, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
With image
.Name = "img" & Rng.Address(0, 0)
.LockAspectRatio = False 'proportions d'origine lorsque vous la redimensionnez(faux!!!!!!!)
.Placement = xlMoveAndSize
End With
End Sub

Sub NEWIMG4()
Dim ficimg As String, image As Shape, Rng As Range
Set Rng = Range("K162:O174")
ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix du fichier
If ficimg = Faux Then Exit Sub
Set image = ActiveSheet.Shapes.AddPicture(ficimg, False, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
With image
.Name = "img" & Rng.Address(0, 0)
.LockAspectRatio = False 'proportions d'origine lorsque vous la redimensionnez(faux!!!!!!!)
.Placement = xlMoveAndSize
End With
End Sub
Sub NEWIMG5()

Dim ficimg As String, image As Shape, Rng As Range
Set Rng = Range("C176:H188")
ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix du fichier
If ficimg = Faux Then Exit Sub
Set image = ActiveSheet.Shapes.AddPicture(ficimg, False, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
With image
.Name = "img" & Rng.Address(0, 0)
.LockAspectRatio = False 'proportions d'origine lorsque vous la redimensionnez(faux!!!!!!!)
.Placement = xlMoveAndSize
End With
End Sub
Sub NEWIMG6()

Dim ficimg As String, image As Shape, Rng As Range
Set Rng = Range("K176:O188")
ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix du fichier
If ficimg = Faux Then Exit Sub
Set image = ActiveSheet.Shapes.AddPicture(ficimg, False, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
With image
.Name = "img" & Rng.Address(0, 0)
.LockAspectRatio = False 'proportions d'origine lorsque vous la redimensionnez(faux!!!!!!!)
.Placement = xlMoveAndSize
End With
End Sub

MACRO QUI DOIT ME PERMETTRE D'EFFACER TOUTES LES PHOTOS
Cela me met une erreur dès qu'un emplacement defini plus haut est vide
je n'arrive pas a passe a l'emplacement suivant si l'emplacement est vide
Sub SUPIMG()
Dim Rng As Range, shp As Shape
Set Rng = Range("C149:H160")
Set shp = ActiveSheet.Shapes("img" & Rng.Address(0, 0))
If Not shp Is Nothing Then shp.Delete

Set Rng = Range("K149:O160")
Set shp = ActiveSheet.Shapes("img" & Rng.Address(0, 0))
If Not shp Is Nothing Then shp.Delete

Set Rng = Range("C162:H174")
Set shp = ActiveSheet.Shapes("img" & Rng.Address(0, 0))
If Not shp Is Nothing Then shp.Delete

Set Rng = Range("K162:O174")
Set shp = ActiveSheet.Shapes("img" & Rng.Address(0, 0))
If Not shp Is Nothing Then shp.Delete

Set Rng = Range("C176:H188")
Set shp = ActiveSheet.Shapes("img" & Rng.Address(0, 0))
If Not shp Is Nothing Then shp.Delete

Set Rng = Range("K176:O188")
Set shp = ActiveSheet.Shapes("img" & Rng.Address(0, 0))
If Not shp Is Nothing Then shp.Delete

End Sub

Staple1600 · 10 Avril 2020

Re

•>luc50*
J'en déduis que tu n'as pas fait le test proposé dans le message#8
(C'était bien la peine de passer du temps dessus pour le mettre au point...)

Je laisse donc patricktoulon prendre le relais.

luc50* · 10 Avril 2020

Desole
staplle 1600 j ai fait ton test et il n'efface effectivement que les images en colonne b et g
et moi j'ai des photo en c k h o en plus de b et g et je ne suis pas parvenu a tous concilie
mais si tu a une solution pour tout effacer je suis preneur

luc50* · 10 Avril 2020

je me sui peut etre ma exprimer
j'ai six emplacement de photos que je peu remplir ou pas
leffecement fpnctionne tres bien des qu'il y les 6 photos mais si lin'yen a qu'une cela ne fonctionne pas

Staple1600 · 10 Avril 2020

Re

1) C'est Staple pas staplle
2) Si tu parles de tout effacer, es-tu vraiment sûr d'avoir étudier le code du message#8...
Car ceci y figurait ActiveSheet.DrawingObjects.Delete
et cela efface tout.

Microsoft 365 supression image

luc50*

XLDnaute Nouveau

Staple1600

Staple1600

XLDnaute Barbatruc

luc50*

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

luc50*

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

luc50*

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

luc50*

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

luc50*

XLDnaute Nouveau

luc50*

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

Discussions similaires

Microsoft 365 supression image

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Nouveau

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency