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 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60
| 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
Sub copieEcran_et_Sauvegarde()
'michelxld le 30.09.2005
Dim x As Byte
Dim Sh As Shape
Dim monImage As String
keybd_event vbKeySnapshot, 1, 0&, 0&
DoEvents
x = ActiveSheet.Shapes.Count
Application.ScreenUpdating = False
ActiveSheet.Range("A1").Select
ActiveSheet.Paste
'verifie si le collage effectué correspond à une image
If x = ActiveSheet.Shapes.Count Then
Application.ScreenUpdating = True
MsgBox "Opération annulée"
Exit Sub
Else
Set Sh = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
monImage = "C:\monImage.jpg"
With ActiveSheet.ChartObjects.Add(0, 0, Sh.Width, Sh.Height).Chart
.Paste
.Export monImage, "JPG"
End With
With ActiveSheet
.ChartObjects(ActiveSheet.ChartObjects.Count).Delete
.Shapes(ActiveSheet.Shapes.Count).Delete
End With
Application.ScreenUpdating = True
'-------------------------------------------------------------
'option pour les utilisateur de Windows XP :
'visualisation de l'image créée avec avec l'apercu images_telecopies Windows
'testé avec Excel2002 et WinXP
'ShellExecute 0, "open", "rundll32.exe", _
"C:\WINDOWS\System32\shimgvw.dll,ImageView_Fullscreen " & monImage, 0, 1
'-------------------------------------------------------------
End If
End Sub |
Partager