Beste forumleden,
Ik heb inmiddels een code gevonden waarmee een schermkopie gemaakt kan worden. De kopie wordt opgeslagen als een afbeelding in een nieuw werkboek. Dit is al een grote stap in de juiste richting. Ik vraag me af of het ook mogelijk is dat de afbeelding opgeslagen wordt (als jpg o.i.d.) op het bureaublad ipv een nieuw werkboek?
In ieder geval al bedankt voor het meedenken. Als het niet mogelijk is hoor ik het ook graag! :thumb:
Ik heb inmiddels een code gevonden waarmee een schermkopie gemaakt kan worden. De kopie wordt opgeslagen als een afbeelding in een nieuw werkboek. Dit is al een grote stap in de juiste richting. Ik vraag me af of het ook mogelijk is dat de afbeelding opgeslagen wordt (als jpg o.i.d.) op het bureaublad ipv een nieuw werkboek?
In ieder geval al bedankt voor het meedenken. Als het niet mogelijk is hoor ik het ook graag! :thumb:
Code:
Option Explicit
'#######################################################################################
'Module code for capturing a screen image (Print Screen) and pasting to a new workbook
'Created on November 14th, 2009, compiled by Zack Barresse
'Compiled utilizing the following resources:
' http://www.ac6la.com/makegif.html
' http://www.andreavb.com/tip090001.html
'#######################################################################################
Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
Private Const SRCCOPY = &HCC0020 ' (DWORD) destination = source
Private Type DEVMODE
dmDeviceName As String * CCHDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Long
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
'API
Declare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
Declare Function EmptyClipboard Lib "user32.dll" () As Long
Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function CloseClipboard Lib "user32.dll" () As Long
Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Declare Function BitBlt Lib "gdi32.dll" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As DEVMODE) As Long
Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Declare Function CountClipboardFormats Lib "user32" () As Long
Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Declare Function CreateIC Lib "GDI32" Alias "CreateICA" _
(ByVal lpDriverName As String, ByVal lpDeviceName As String, _
ByVal lpOutput As String, lpInitData As Long) As Long
Declare Function GetDeviceCaps Lib "GDI32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Sub GetPrintScreen()
'##### SET SCREEN CAPTURE SIZES HERE
Call CaptureScreen(0, 0, 800, 600)
End Sub
Public Sub ScreenToGIF_NewWorkbook()
Dim wbDest As Workbook, wsDest As Worksheet
Dim FromType As String, PicHigh As Single
Dim PicWide As Single, PicWideInch As Single
Dim PicHighInch As Single, DPI As Long
Dim PixelsWide As Integer, PixelsHigh As Integer
Call TOGGLEEVENTS(False)
Call GetPrintScreen
If CountClipboardFormats = 0 Then
MsgBox "Clipboard is currently empty.", vbExclamation, "Nothing to Paste"
GoTo EndOfSub
End If
'Determine the format of the current clipboard contents. There may be multiple
'formats available but the Paste methods below will always (?) give priority
'to enhanced metafile (picture) if available so look for that first.
If IsClipboardFormatAvailable(14) <> 0 Then
FromType = "pic"
ElseIf IsClipboardFormatAvailable(2) <> 0 Then
FromType = "bmp"
Else
MsgBox "Clipboard does not contain a picture or bitmap to paste.", _
vbExclamation, "No Picture"
Exit Sub
End If
Application.StatusBar = "Pasting from clipboard ..."
Set wbDest = Workbooks.Add(xlWBATWorksheet)
Set wsDest = wbDest.Sheets(1)
wbDest.Activate
wsDest.Activate
wsDest.Range("B3").Activate
'Paste a picture/bitmap from the clipboard (if possible) and select it.
'The clipboard may contain both text and picture/bitmap format items. If so,
'using just ActiveSheet.Paste will paste the text. Using Pictures.Paste will
'paste a picture if a picture/bitmap format is available, and the Typename
'will return "Picture" (or perhaps "OLEObject"). If *only* text is available,
'Pictures.Paste will create a new TextBox (not a picture) on the sheet and
'the Typename will return "TextBox". (This condition now checked above.)
On Error Resume Next 'just in case
wsDest.Pictures.Paste.Select
On Error GoTo 0
'If the pasted item is an "OLEObject" then must convert to a bitmap
'to get the correct size, including the added border and matting.
'Do this via a CopyPicture-Bitmap and then a second Pictures.Paste.
If TypeName(Selection) = "OLEObject" Then
With Selection
.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
.Delete
ActiveSheet.Pictures.Paste.Select
'Modify the FromType (used below in the suggested file name)
'to signal that the original clipboard image is not being used.
FromType = "ole object"
End With
End If
'Make sure that what was pasted and selected is as expected.
'Note this is the Excel TypeName, not the clipboard format.
If TypeName(Selection) = "Picture" Then
With Selection
PicWide = .Width
PicHigh = .Height
.Delete
End With
Else
'Can get to here if a chart is selected and "Copy"ed instead of "Copy Picture"ed.
'Otherwise, ???.
If TypeName(Selection) = "ChartObject" Then
MsgBox "Use Shift > Edit > Copy Picture on charts, not just Copy.", _
vbExclamation, "Got a Chart Copy, not a Chart Picture"
Else
MsgBox "Excel pasted a '" & TypeName(Selection) & "' instead of a Picture.", _
vbExclamation, "Not a Picture"
End If
'Clean up and quit.
ActiveWorkbook.Close SaveChanges:=False
GoTo EndOfSub
End If
'Add an empty embedded chart, sized as above, and activate it.
'Positioned at cell B3 just for convenient debugging and final viewing.
'Tip from Jon Peltier: Just add the embedded chart directly, don't use the
'macro recorder method of adding a new separate chart sheet and then relocating
'the chart back to a worksheet.
With Sheets(1)
.ChartObjects.Add(.Range("B3").Left, .Range("B3").Top, PicWide, PicHigh).Activate
End With
'Paste the [resized] bitmap into the ChartArea, which creates ActiveChart.Shapes(1).
On Error Resume Next
ActiveChart.Pictures.Paste.Select
On Error GoTo 0
If TypeName(Selection) = "Picture" Then
With ActiveChart
'Adjust the position of the pasted picture, aka ActiveChart.Shapes(1).
'Adjustment is slightly greater than the .ChartArea.Left/Top offset, why ???
'''' .Shapes(1).IncrementLeft -1
'''' .Shapes(1).IncrementTop -4
'Remove chart border. This must be done *after* all positioning and sizing.
' .ChartArea.Border.LineStyle = 0
End With
'Show pixel size info above the picture-in-chart-soon-to-be-GIF/JPEG/PNG.
PicWideInch = PicWide / 72 'points to inches ("logical", not necessarily physical)
PicHighInch = PicHigh / 72
DPI = PixelsPerInch() 'typically 96 or 120 dpi for displays
PixelsWide = PicWideInch * DPI
PixelsHigh = PicHighInch * DPI
Else
'Something other than a Picture was pasted into the chart.
'This is very unlikely.
MsgBox "Clipboard corrupted, possibly by another task."
End If
EndOfSub:
Call TOGGLEEVENTS(True)
End Sub
Public Sub TOGGLEEVENTS(blnState As Boolean)
'Originally written by Zack Barresse
With Application
.DisplayAlerts = blnState
.EnableEvents = blnState
.ScreenUpdating = blnState
If blnState Then .CutCopyMode = False
If blnState Then .StatusBar = False
End With
End Sub
Public Function PixelsPerInch() As Long
'Get the screen resolution in pixels per inch.
'Under Excel 2000 and above could use Application.DefaultWebOptions.PixelsPerInch.
Dim hdc As Long
hdc = CreateIC("DISPLAY", vbNullString, vbNullString, 0)
PixelsPerInch = GetDeviceCaps(hdc, 88) 'LOGPIXELSX = 88 = Logical pixels/inch in X
DeleteDC (hdc)
End Function
'Screen Capture Procedure, coordinates are expressed in pixels
Public Sub CaptureScreen(Left As Long, Top As Long, Width As Long, Height As Long)
Dim srcDC As Long, trgDC As Long, BMPHandle As Long, dm As DEVMODE
srcDC = CreateDC("DISPLAY", "", "", dm)
trgDC = CreateCompatibleDC(srcDC)
BMPHandle = CreateCompatibleBitmap(srcDC, Width, Height)
SelectObject trgDC, BMPHandle
BitBlt trgDC, 0, 0, Width, Height, srcDC, Left, Top, SRCCOPY
OpenClipboard 0&
EmptyClipboard
SetClipboardData 2, BMPHandle
CloseClipboard
DeleteDC trgDC
ReleaseDC BMPHandle, srcDC
End Sub
[ATTACH]274831.vB[/ATTACH]
