Enregistrer une plage de cellule en image
Bonjour à tous
J'ai déniché ce code pour enregistrer une plage de cellule en image mais j'ai du mal à me l'approprier totalement.
Plutôt que de laisser le choix à l'utilisateur le chemin d'enregistrement de l'image j'aimerais la définir.
En fait ce que je souhaiterai c'est enregistrer l'image deux fois vers deux chemins différents et avec leur nom différent, mais malgré mes essais et mes connaissances limitées je n'arrive pas faire ce que je veux du code ...
Si quelqu'un veut bien me donner un coup de pouce.
Merci d'avance et bonne après-midi
Option Explicit
Sub EnregistrerImage()
' Exporter la plage de cellules sélectionnée vers une image PNG
Dim rngToPNG As Range ' La plage à enregistrer
Dim booGrid As Boolean ' Pour rétablir la grille telle qu'elle
Dim varExportPath As Variant ' Chemin complet d'enregistrement de l'image
' Sélection de la plage de cellule
Range("A1:D10").Select
' Demande à l'utilisateur le chemin où enregistrer l'image
varExportPath = Application.GetSaveAsFilename(ActiveWorkbook.Path & "\image.png", "Image (*.png),*.png", , "Enregistrer sous forme d'image")
If varExportPath <> False Then
' Masquer les coulisses
Application.ScreenUpdating = False ' Figer l'écran
booGrid = ActiveWindow.DisplayGridlines ' Mémoriser la grille
ActiveWindow.DisplayGridlines = False ' Masquer la grille
' Mémoriser la zone sélectionnée par l'utilisateur
Set rngToPNG = Selection
' Sélectionner une cellule très loin du tableau pour être sûr que la création de la zone de graphique soit vide
Range("A1").SpecialCells(xlLastCell).Offset(5, 5).Select
' Création d'une zone de graphique et sélection de celle-ci
ActiveSheet.Shapes.AddChart2(201, xlColumnClustered).Select
' Redimentionnement à la taille de la zone de cellules
ActiveSheet.Shapes(1).Height = rngToPNG.Rows.Height
ActiveSheet.Shapes(1).Width = rngToPNG.Columns.Width
' Copier la zone de cellules sous forme d'image
rngToPNG.CopyPicture xlScreen, xlPicture
' Collage dans la zone de graphique
ActiveChart.Paste
' Export sous forme d'image
ActiveChart.Export Filename:=varExportPath, FilterName:="PNG"
' Retour à la normale
ActiveSheet.Shapes(1).Delete
rngToPNG.Select
ActiveWindow.DisplayGridlines = booGrid
Application.ScreenUpdating = True
' Confirmation
MsgBox "L'image a bien été enregistrée...", vbInformation
End If
End Sub
Bonjour à tous !
Après une nuit de réflexion j'ai réussi à débloquer la situation (je vais valider ma propre réponse pour une fois !).
Il fallait "juste" intégrer le chemin dans
varExportPath =
pour ceux qui sont intéressés.
Bonne journée et bonne continuation
Dim rngToPNG As Range ' La plage à enregistrer
Dim booGrid As Boolean ' Pour rétablir la grille telle qu'elle
Dim varExportPath As Variant ' Chemin complet d'enregistrement de l'image
' Sélection de la plage de cellule
Range("A1:D10").Select
' Demande à l'utilisateur le chemin où enregistrer l'image
varExportPath = "C:\Chemin\Image.png" 'Application.GetSaveAsFilename(ActiveWorkbook.Path & "\image.png", "Image (*.png),*.png", , "Enregistrer sous forme d'image")
If varExportPath <> False Then
' Masquer les coulisses
Application.ScreenUpdating = False ' Figer l'écran
booGrid = ActiveWindow.DisplayGridlines ' Mémoriser la grille
ActiveWindow.DisplayGridlines = False ' Masquer la grille
' Mémoriser la zone sélectionnée par l'utilisateur
Set rngToPNG = Selection
' Sélectionner une cellule très loin du tableau pour être sûr que la création de la zone de graphique soit vide
Range("A1").SpecialCells(xlLastCell).Offset(5, 5).Select
' Création d'une zone de graphique et sélection de celle-ci
ActiveSheet.Shapes.AddChart2(201, xlColumnClustered).Select
' Redimentionnement à la taille de la zone de cellules
ActiveSheet.Shapes(1).Height = rngToPNG.Rows.Height
ActiveSheet.Shapes(1).Width = rngToPNG.Columns.Width
' Copier la zone de cellules sous forme d'image
rngToPNG.CopyPicture xlScreen, xlPicture
' Collage dans la zone de graphique
ActiveChart.Paste
' Export sous forme d'image
ActiveChart.Export Filename:=varExportPath, FilterName:="PNG"
' Retour à la normale
ActiveSheet.Shapes(1).Delete
rngToPNG.Select
ActiveWindow.DisplayGridlines = booGrid
Application.ScreenUpdating = True
' Confirmation
MsgBox "L'image a bien été enregistrée...", vbInformation
End If
End Sub