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
|
Sub ExportImage()
Dim f As Worksheet, img As Shape, nomShape As String, nomImg As String
Dim Emplacement As Range
' L'image est déjà sélectionnée au départ
'
répertoire = "Macintosh HD:Users:PATRICK:MonDomaine:ImagesExcel"
Set f = ActiveSheet
If Left(TypeName(Selection), 7) = "Picture" Then
' Nom de l'image
nomShape = Selection.Name
' Nom du ficher à enregistrer
nomImg = "ImagesExcel-170399"
Else
MsgBox "Vous n'avez pas sélectionné d'image.", vbInformation, "Erreur de sélection"
End If
' Stockage de l'image
Set img = f.Shapes(nomShape)
Hauteur = f.Shapes(nomShape).Height
' Copie
img.CopyPicture
' Paste de l'image copiée avec création d'un graphique
f.ChartObjects.Add(0, 0, img.Width, Hauteur).Chart.Paste
' Enregistrement
f.ChartObjects(1).Chart.Export Filename:=répertoire & ":" & nomImg & ".png", FilterName:="png"
' Suppression du graphique
f.ChartObjects(1).Delete
End Sub |
Partager