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