VBA 屏幕截图并保存到桌面答案

【问题标题】：VBA screen capture and save to a desktopVBA 屏幕截图并保存到桌面
【发布时间】：2021-06-18 13:31:38
【问题描述】：

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

归功于Using Excel VBA Macro To Capture + Save Screenshot of Specific Area In Same File 我尝试了这段代码，它可以工作，但我想稍微改变一下。如何将屏幕截图（jpg格式）保存到桌面文件夹中，而不是粘贴在活动工作表上？非常感谢！

【问题讨论】：

标签： excel vba screenshot screen-capture

【解决方案1】：

如果在图表上粘贴图片，可以将其保存为图片文件。

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

【讨论】：

我试试看。当我在桌面上打开图片时，它显示一条消息“此操作已返回，因为超时期限已过。”

【解决方案2】：

将以下代码放入模块中

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

然后你可以重写你的代码

Sub CopyScreen()

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

这会将剪贴板保存到 C:\TEMP 中的位图文件中（该目录应该存在！）。

【讨论】：