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