Sauver image dans un fichier définit et afficher le path
c
Bonjour,
Je cherche créer une macro qui puisse supprimer une image dans une cellule si il y en a une, importer une image dans cette cellule, sauver cette image dans un fichier définit et afficher dans une autre cellule le Path pour l’image sauvée.
Si quelqu’un a un code que je puisse utiliser ce serait super !
Merci encore !
Pour le moment mon code ressemble ca :
Private Sub CommandButton1_Click()
Dim Emplacement As Range
Dim Img As Object
Dim ShapeObj As Shape
'Boucle pour supprimer l'ancienne image
For Each ShapeObj In ActiveSheet.Shapes
If ShapeObj.name = "*" Then ActiveSheet.Shapes("*").Delete
Next ShapeObj
If Application.Dialogs(xlDialogInsertPicture).Show Then
'Définit l'emplacement de l'image
Set Emplacement = Cells(2, 9)
Set Img = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)
With Img.ShapeRange
'Nommer l'image insérée (Pour la supprimer plus facilement ensuite)
.name = ListBox1 + "image"
.LockAspectRatio = msoTrue
.Left = Emplacement.Left
.Top = Emplacement.Top
.Height = Emplacement.Height
.Width = Emplacement.Width
End With
Else
MsgBox "Insertion d'image interrompue."
End If
End Sub
c
voila ce que j'ai fait:
vous en pensez quoi?
il ne me reste plus qu'a obliger à séléctionner des images mais autrement ca fonctionne
Private Sub CommandButton1_Click()
On Error GoTo ErrorHandler
Dim NomPicture As String
Dim Picture1 As Variant
Picture1 = Application.GetOpenFilename( _
FileFilter:="all,*.*", _
Title:="Sélectionnez une image à sauvegarder")
NomPicture = Right(Picture1, Len(Picture1) - InStrRev(Picture1, "\")) 'trouve le nom du fichier
FileCopy Picture1, "C:\blabla" & NomPicture 'Copie du fichier dans l'autre emplacement
ActiveCell.Offset(0, 8) = "C:\blabla" & NomPicture
ActiveSheet.Pictures.Insert("C:\blabla" & NomPicture).Select
With Selection.ShapeRange
.Left = ActiveCell.Offset(0, 8).Left
.Top = ActiveCell.Offset(0, 8).Top
End With
form1.Image1.Picture = LoadPicture("C:\blabla\" & NomPicture)
Exit Sub
ErrorHandler:
MsgBox "L'image téléchargée n'est pas valide veuillez la changer"
End Sub