Copie d'écran - une variante

[ouskel'n'or]

Sur une "vieille" proposition de Cafeine, sur l'enregistrement de cellules sous forme de fichier gif, reprise ici dans la FAQ, une variante qui permet de réaliser une copie d'écran et de l'enregistrer en jpg.
Ce code peut être extrapolé pour être utilisé dans Word ou dans PowerPoint mais, en l'état, ne peut se libérer d'un passage obligé par Excel.
Un graphique, vidé de sa subtance, est en effet nécessaire à l'export sous forme de fichier image, la méthode "Export" ne s'appliquant qu'aux graphes.

Les déclarations

Code :

1
2
3
4
5
6
7
Option Explicit
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _
ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
 
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Le code :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub CopieEcran_En_jpg()
Dim FL As Worksheet, Limage As String, Shp As Shape
    keybd_event vbKeySnapshot, 1, 0&, 0& 'réalise la copie de l'écran
    DoEvents
    Application.ScreenUpdating = False
    Set FL = Worksheets.Add 'ajoute une feuille au classeur
    DoEvents
    Range("A1").Select
    ActiveSheet.Paste   'Colle l'image dans la feuille
    DoEvents
    Set Shp = ActiveSheet.Shapes(ActiveSheet.Shapes.Count) 'sert à dimensionner le graphe
    Limage = "C:\Limage.jpg"
    With ActiveSheet.ChartObjects.Add(0, 0, Shp.Width, Shp.Height).Chart
        .Paste                  'Colle l'image dans le graphe à la bonne dimension
        .Export Limage, "JPG"   'crée le fichier dans le répertoire voulu
    End With
    Application.DisplayAlerts = False
        FL.Delete 'supprime la feuille ajoutée
    Application.DisplayAlerts = False
    Application.ScreenUpdating = True
 
    'Affichage de l'image créée
    ShellExecute 0, vbNullString, "C:\Limage.jpg", vbNullString, vbNullString, 0
End Sub