VBA screen capture and save to a desktop

Question

Option Explicit
Sub CopyScreen()

Application.SendKeys "({1068})", True
DoEvents
ActiveSheet.Paste

Dim shp As Shape
With ActiveSheet
    Set shp = .Shapes(.Shapes.Count)
End With
shp.Height = 600
shp.Width = 800

Dim h As Single, w As Single
h = -(600 - shp.Height)
w = -(800 - shp.Width)

shp.LockAspectRatio = False
shp.PictureFormat.CropTop = 180
shp.PictureFormat.CropBottom = 80
shp.PictureFormat.CropRight = 15


End Sub

Credit to Using Excel VBA Macro To Capture + Save Screenshot of Specific Area In Same File I try this code and it works, but I would like to change a little bit. Instead of pasting on the active sheet, how can I save the screenshot (jpg format) to a folder in desktop? Thank you so much!

score 0 · Answer 1 · answered Mar 21 '21 at 22:52

If you paste a picture on the chart, you can save it as a picture file.

Sub CopyScreen()
    Dim Ws As Worksheet, wdArt As Shape, WB As Workbook
    Dim obj As ChartObject, Cht As Chart
    Dim myFn As String
    Dim w As Single, h As Single
    
    Set Ws = ActiveSheet
    myFn = ThisWorkbook.Path & "\" & "test.jpg"
    Application.SendKeys "({1068})", True
    DoEvents
    ActiveSheet.Paste
    w = Selection.Width
    h = Selection.Height
    Set obj = Ws.ChartObjects.Add(Range("a1").Left, Range("a1").Top, w, h)
     
    obj.Chart.Paste
    obj.ShapeRange.Line.Visible = msoFalse
    obj.Chart.Export myFn, "jpg"
    obj.Delete
    

End Sub

I try it. When I open the picture on desktop, it shows a message "this operation returned because the timeout period expired." — Cheryl Chan, Mar 22 '21 at 09:07

score 0 · Answer 2 · answered Mar 22 '21 at 13:16

Put the following code into a module

Option Explicit

Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
    ByRef PicDesc As PIC_DESC, _
    ByRef RefIID As GUID, _
    ByVal fPictureOwnsHandle As Long, _
    ByRef IPic As IPictureDisp) As Long
Private Declare Function CopyImage Lib "user32.dll" ( _
    ByVal handle As Long, _
    ByVal un1 As Long, _
    ByVal n1 As Long, _
    ByVal n2 As Long, _
    ByVal un2 As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" ( _
    ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32.dll" ( _
    ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" ( _
    ByVal wFormat As Integer) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type PIC_DESC
    lngSize As Long
    lngType As Long
    lnghPic As Long
    lnghPal As Long
End Type

Private Const PICTYPE_BITMAP = 1
Private Const CF_BITMAP = 2
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Private Const GC_CLASSNAMEMSEXCEL = "XLMAIN"

Function Paste_Picture() As IPictureDisp
    
    Dim lngReturn As Long, lngCopy As Long, lngPointer As Long
    
    If IsClipboardFormatAvailable(CF_BITMAP) <> 0 Then
        lngReturn = OpenClipboard(FindWindow(GC_CLASSNAMEMSEXCEL, Application.Caption))
        If lngReturn > 0 Then
            lngPointer = GetClipboardData(CF_BITMAP)
            lngCopy = CopyImage(lngPointer, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            Call CloseClipboard
            If lngPointer <> 0 Then Set Paste_Picture = Create_Picture(lngCopy, 0&, CF_BITMAP)
        End If
    End If
    
    End Function

Private Function Create_Picture( _
        ByVal lnghPic As Long, _
        ByVal lnghPal As Long, _
        ByVal lngPicType As Long) As IPictureDisp
    
    Dim udtPicInfo As PIC_DESC, udtID_IDispatch As GUID
    Dim objPicture As IPictureDisp
    
    With udtID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    
    With udtPicInfo
        .lngSize = Len(udtPicInfo)
        .lngType = PICTYPE_BITMAP
        .lnghPic = lnghPic
        .lnghPal = lnghPal
    End With
    
    Call OleCreatePictureIndirect(udtPicInfo, udtID_IDispatch, 0&, objPicture)
    
    Set Create_Picture = objPicture
    
End Function

Then you could rewrite your code to

Sub CopyScreen()

Application.SendKeys "({1068})", True
DoEvents
    Dim objPicture As IPictureDisp
    Set objPicture = Paste_Picture
    SavePicture objPicture, "c:\temp\test.bmp"
End Sub

This will save the clipboard into a bitmap file in C:\TEMP (this directory should exist!).

VBA screen capture and save to a desktop

2 Answers2