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
| Sub CAPTURE_FEUILLE()
Dim mes As Range, monImage As String, Sh As Shape, m As String
m = InputBox("NOM DE L'IMAGE", "DEFINIR UN NOM")
If m = "" Then: Exit Sub 'si l'operation est annulée
Set mes = Application.InputBox("Choix de cellule(s)", Type:=8)
monImage = mes.Address
Range(monImage).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Sheets("Feuil1").Select
ActiveSheet.Paste
'Récupère la dernière forme de la feuille
Set Sh = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
'Définit le nom et le lieu de stockage de l'image
monImage = "C:\Users\Dominique\Pictures\" & m & ".jpg"
'Colle l'image dans un graphique
With ActiveSheet.ChartObjects.Add(0, 0, Sh.Width, Sh.Height).Chart
.Paste
'Sauvegarde l'image du graphique au format jpg
.Export monImage, "JPG"
End With
'Supprime le graphique et la forme.
With ActiveSheet
.ChartObjects(ActiveSheet.ChartObjects.Count).Delete
.Shapes(ActiveSheet.Shapes.Count).Delete
End With
End Sub |
Partager