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

Question

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

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

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

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

我正在尝试使用按钮自动化，而不是使用剪切工具。

Answer 1

Without using 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粘贴图片，它将是您可以操作的形状。

调整大小：一旦掌握了形状，只需根据需要指定其Height和Width属性：

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

定位它：使用形状TopLeftCell property。

裁剪：使用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

Answer 3

let nib = UINib(nibName: "MyCustomTableViewCell", bundle: nil)
_ = nib.instantiate(withOwner: self, options: nil)[0] 
myTableView.register(nib, forCellReuseIdentifier: "mycustomcellreuseidentifier")