capture a screenshot using an excel macro

capture-screen.vbs

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
'#######################################################################################
' Updated by Avery on 2020-06-23 to make the code work with 64-bit Excel
' Updated by Avery on 2020-06-26 to hide the Excel window for 0.1 seconds in order to screenshot what's behind
' Disclaimer: this is my first time seeing VBA, so the edits may not be the best, but it seems to work
' Rewritten utilizing some of the following resources:
'   http://www.vbaexpress.com/kb/getarticle.php?kb_id=1075
'   https://www.exceltip.com/general-topics-in-vba/determine-the-screen-size-using-vba-in-microsoft-excel.html
'   https://jkp-ads.com/Articles/apideclarations.asp
'   https://www.cadsharp.com/docs/Win32API_PtrSafe.txt
'   https://codekabinett.com/rdumps.php?Lang=2&targetDoc=windows-api-declaration-vba-64-bit
'#######################################################################################

Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
Private Const CCFORMNAME As Integer = 32
Private Const SRCCOPY = &HCC0020 ' (DWORD) destination = source

Public Const SM_CXSCREEN = 0
Public Const SM_CYSCREEN = 1
Dim APPLICATION_HWND As LongPtr

Private Type DEVMODE
    dmDeviceName As String * CCHDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Integer
    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 * CCFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Long
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
    dmICMMethod As Long
    dmICMIntent As Long
    dmMediaType As Long
    dmDitherType As Long
    dmReserved1 As Long
    dmReserved2 As Long
End Type


'API
Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Declare PtrSafe Function EmptyClipboard Lib "user32" () As LongPtr
Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As LongPtr, ByVal hMem As LongPtr) As LongPtr
Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr
Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Declare PtrSafe Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As DEVMODE) As LongPtr
Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
Declare PtrSafe Function CountClipboardFormats Lib "user32" () As Long
Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Declare PtrSafe Function CreateIC Lib "gdi32" Alias "CreateICA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As DEVMODE) As LongPtr
Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long

Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Declare PtrSafe Function EnumWindows Lib "user32" (ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long
Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Boolean
Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As LongPtr) As Long
Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr

Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)


'Find current open window (should be Excel)
Private Function EnumWindowsProc(ByVal hwnd As LongPtr, lParam As LongPtr) As LongPtr
    Dim visible As Boolean: visible = IsWindowVisible(hwnd)
    
    If visible And hwnd <> APPLICATION_HWND Then
        Dim windowTitle As String: windowTitle = Space(260)
        Call GetWindowText(hwnd, windowTitle, 260)
        windowTitle = Trim(windowTitle)
        windowTitle = Left(windowTitle, Len(windowTitle) - 1)  'remove null terminator
        If Len(windowTitle) > 0 And windowTitle <> "Start" Then
            Debug.Print hwnd
            Debug.Print windowTitle
            lParam = hwnd
            EnumWindowsProc = 0
        Else
            EnumWindowsProc = 1
        End If
    Else
        EnumWindowsProc = 1
    End If
End Function


'Capture screenshot, hiding Excel first so it doesn't occlude the window of interest
Sub GetPrintScreen()
    Application.ScreenUpdating = False  'not sure how much this optimization helps
    APPLICATION_HWND = Application.hwnd
    Dim hwnd As LongPtr
    
    'Hide Excel in the background
    Call EnumWindows(AddressOf EnumWindowsProc, VarPtr(hwnd))
    SetForegroundWindow hwnd
    DoEvents
    Sleep 100
    
    'Screenshot
    Call CaptureScreen(0, 0, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN))
    
    'Restore Excel to foreground
    SetForegroundWindow APPLICATION_HWND
    Application.ScreenUpdating = True
End Sub


'Capture screenshot with Excel in the picture
Sub JustPrintScreen()
    Call CaptureScreen(0, 0, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN))
End Sub


'This seems like a generic function to paste any copied image into a new workbook
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


'Originally written by Zack Barresse
Public Sub TOGGLEEVENTS(blnState As Boolean)
    With Application
        .DisplayAlerts = blnState
        .EnableEvents = blnState
        .ScreenUpdating = blnState
        If blnState Then .CutCopyMode = False
        If blnState Then .StatusBar = False
    End With
End Sub


'Get the screen resolution in pixels per inch
Public Function PixelsPerInch() As Long
   PixelsPerInch = Application.DefaultWebOptions.PixelsPerInch
   'Before Microsoft Office 2000, there was no Application.DefaultWebOptions.PixelsPerInch
   'Dim hdc As LongPtr
   '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 LongPtr, trgDC As LongPtr, BMPHandle As LongPtr, 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