使用Excel VBA宏捕获+保存同一文件中特定区域的屏幕截图

Question

我正在尝试创建一个宏,它使用ActiveX控件按钮(单击)来截取我的桌面屏幕截图并将其保存在与按钮相同的Excel工作表中.如何创建尺寸为800x600的屏幕截图(不是完整的桌面视图),然后将其粘贴到与按钮相同的工作表的左侧？我尝试了很多方法,包括sendkeys(最简单).

我将捕获过程保存在一个模块中:

Sub PasteScreenShot()
Application.SendKeys "({1068})"
ActiveSheet.Paste
End Sub

然后在ActiveX按钮代码中调用sub.捕获工作,但我无法找到一种方法来操纵其区域抓取或其在工作表上的粘贴位置.

我试图使用按钮自动化而不是使用剪切工具.

Answer 1

不使用 SendKeys

Option Explicit

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
  bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Const VK_SNAPSHOT = &H2C

Sub PrintScreen()
    keybd_event VK_SNAPSHOT, 1, 0, 0
    ActiveSheet.Paste
End Sub

但是,使用这种方法,如果您使用多个监视器,它将只捕获活动监视器,因此如果您需要捕获另一个监视器,则需要进一步努力(这可能通过API调用完成,但我还没有得到那么远).

注意:该AppActivate语句可用于激活另一个(非Excel)应用程序,如果这样做,那么该keybd_event函数将仅捕获该应用程序,例如;

AppActivate "Windows Command Processor" 'Modify as needed
keybd_event VK_SNAPSHOT, 1, 0, 0
ActiveSheet.Paste

使用SendKeys,解决问题:

虽然SendKeys众所周知,如果由于上述API方法的限制而需要使用此方法,您可能会遇到一些问题.正如我们都观察到的那样,调用ActiveSheet.Paste实际上并没有粘贴打印屏幕,而是粘贴了以前在剪贴板队列中的任何内容,以至于在实际粘贴之前需要单击按钮调用宏两次截图.

我尝试了一些不同的东西但无济于事,但忽略了显而易见的事情:在调试时,如果我打开断点ActiveSheet.Paste,我就不再看到上述问题了!

这告诉我,SendKeys在下一行代码执行之前,处理速度不足以将数据放入剪贴板中,为解决该问题,有两种可能的解决方案.

1. 你可以试试Application.Wait.当我测试它时,这种方法似乎有效,但我要提醒它,它也不可靠.
2. 一个更好的选择是 DoEvents,因为它明确地设计用于处理这类事情:

DoEvents将控制权传递给操作系统.在操作系统处理完队列中的事件并且已发送SendKeys队列中的所有密钥后,将返回控制权.

无论我是从IDE,Macros功能区还是从按钮Click事件过程手动运行宏,这都适用于我:

Option Explicit
Sub CopyScreen()

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

Dim shp As Shape
With ActiveSheet
    Set shp = .Shapes(.Shapes.Count)
End With

End Sub

如何定位,调整大小和裁剪图像:

无论您使用哪种方法,一旦使用ActiveSheet.Paste它粘贴图片,将是您可以操作的Shape.

要调整大小:一旦掌握了形状,只需根据需要分配它Height和Width属性:

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

定位它:使用形状的TopLeftCell属性.

要裁剪:使用shp.PictureFormat.Crop(和/或CropLeft,CropTop,CropBottom,CropRight如果你需要微调所需要的屏幕截图的一部分.例如,这裁剪粘贴的截图为800x600.:

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

shp.LockAspectRatio = False
shp.PictureFormat.CropRight = w
shp.PictureFormat.CropBottom = h

Answer 2

您可以在 Excel 32 位的标准模块中尝试此代码。

• 可以通过调用Sub prcSave_Picture_Screen立即捕获屏幕截图，它将捕获整个屏幕并保存到与工作簿相同的路径（如果需要，您可以更改路径和文件名）
• 调用Sub prcSave_Picture_Active_Window 3 秒后也可以捕获活动窗口的屏幕截图（可调）

来源：ms-office-forum.de

Option Explicit

Private Declare Sub Sleep Lib "kernel32.dll" ( _
    ByVal dwMilliseconds As Long)
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
    ByRef PicDesc As PicBmp, _
    ByRef RefIID As GUID, _
    ByVal fPictureOwnsHandle As Long, _
    ByRef IPic As IPicture) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" ( _
    ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" ( _
    ByVal hdc As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" ( _
    ByVal hdc As Long, _
    ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32.dll" ( _
    ByVal hdc As Long, _
    ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "gdi32.dll" ( _
    ByVal hdc As Long, _
    ByVal wStartIndex As Long, _
    ByVal wNumEntries As Long, _
    ByRef lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "gdi32.dll" ( _
    ByRef lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectPalette Lib "gdi32.dll" ( _
    ByVal hdc As Long, _
    ByVal hPalette As Long, _
    ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "gdi32.dll" ( _
    ByVal hdc As Long) As Long
Private 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
Private Declare Function DeleteDC Lib "gdi32.dll" ( _
    ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32.dll" ( _
    ByVal hWnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" ( _
    ByVal hWnd As Long, _
    ByRef lpRect As RECT) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" ( _
    ByVal nIndex As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long

Private Const SM_CXSCREEN = 0&
Private Const SM_CYSCREEN = 1&
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104
Private Const RASTERCAPS As Long = 38

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type PALETTEENTRY
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
End Type

Private Type LOGPALETTE
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(255) As PALETTEENTRY
End Type

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

Private Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type

Public Sub prcSave_Picture_Screen() 'ganzer bildschirm
    stdole.SavePicture hDCToPicture(GetDC(0&), 0&, 0&, _
        GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN)), _
        ThisWorkbook.Path & "\Screenshot.bmp" 'anpassen !!!
End Sub

Public Sub prcSave_Picture_Active_Window() 'aktives Fenster
    Dim hWnd As Long
    Dim udtRect As RECT
    Sleep 3000 '3 sekunden pause um ein anderes Fenster zu aktivieren
    hWnd = GetForegroundWindow
    GetWindowRect hWnd, udtRect
    stdole.SavePicture hDCToPicture(GetDC(0&), udtRect.Left, udtRect.Top, _
        udtRect.Right - udtRect.Left, udtRect.Bottom - udtRect.Top), _
        ThisWorkbook.Path & "\Screenshot.bmp" 'anpassen !!!
End Sub

Private Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Object
    Dim Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With Pic
        .Size = Len(Pic)
        .Type = 1
        .hBmp = hBmp
        .hPal = hPal
    End With
    Call OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
    Set CreateBitmapPicture = IPic
End Function

Private Function hDCToPicture(ByVal hDCSrc As Long, ByVal LeftSrc As Long, _
    ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Object
    Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long
    Dim hPal As Long, hPalPrev As Long, RasterCapsScrn As Long, HasPaletteScrn As Long
    Dim PaletteSizeScrn As Long, LogPal As LOGPALETTE
    hDCMemory = CreateCompatibleDC(hDCSrc)
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    hBmpPrev = SelectObject(hDCMemory, hBmp)
    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)
    HasPaletteScrn = RasterCapsScrn And RC_PALETTE
    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        LogPal.palVersion = &H300
        LogPal.palNumEntries = 256
        Call GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
        hPal = CreatePalette(LogPal)
        hPalPrev = SelectPalette(hDCMemory, hPal, 0)
        Call RealizePalette(hDCMemory)
    End If
    Call BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, 13369376)
    hBmp = SelectObject(hDCMemory, hBmpPrev)
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        hPal = SelectPalette(hDCMemory, hPalPrev, 0)
    End If
    Call DeleteDC(hDCMemory)
    Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
End Function