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

Question

提问by loco

I'm trying to create a macro which uses an ActiveX control button (click) to take a screenshot of my desktop screen and save it within the same excel sheet as the button. How can I create a screenshot 800x600 in size (not full desktop view) and then have it pasted into the left hand side of the same sheet as the button? I have tried this numerous ways including sendkeys (simplest).

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

I saved the capture process in a module:

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

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

And then call the sub in the ActiveX button code. The capture works, but I cannot figure out a way to manipulate its area grab or its pasted location on the sheet.

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

I am trying to automate with buttons rather than using the snipping tool.

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

Answer 1

回答by David Zemens

Without using `SendKeys`

不使用 `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

However, with this approach if you are using multiple monitors, it will only capture the activemonitor, so further effort needs to be made if you need to capture the other monitor (this can probably be done with API calls but I haven't gotten that far).

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

NB: The AppActivatestatement can be used to activate another (non-Excel) application and if you do this, then the keybd_eventfunction will onlycapture that application, e.g;

注意：该AppActivate语句可用于激活另一个（非 Excel）应用程序，如果您这样做，则该keybd_event函数将仅捕获该应用程序，例如；

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

Using `SendKeys`, Problem Solved:

使用`SendKeys`，问题解决：

While SendKeysis notoriously flaky, if you need to use this method due to limiations of the API method described above, you might have some problems. As we both observed, the call to ActiveSheet.Pastewas not actually pasting the Print Screen, but rather it was pasting whatever was previously in the Clipboard queue, to the effect that you needed to click your button to call the macro twice, before it would actually paste the screenshot.

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

I tried a few different things to no avail, but overlooked the obvious: While debugging, if I put a breakpoint on ActiveSheet.Paste, I was no longer seeing the problem described above!

我尝试了一些不同的方法但没有成功，但忽略了一个明显的问题：在调试时，如果我在上设置断点ActiveSheet.Paste，我将不再看到上述问题！

This tells me that the SendKeysis not processed fast enough to put the data in the Clipboard before the next line of code executes, to solve that problem there are two possible solutions.

这告诉我，SendKeys在下一行代码执行之前，处理速度不够快，无法将数据放入剪贴板，要解决该问题，有两种可能的解决方案。

You could try Application.Wait. This method seems to work when I test it, but I'd caution that it's also unreliable.
A better option would be DoEvents, because it's explicitly designed to handle this sort of thing:

你可以试试Application.Wait。这种方法在我测试时似乎有效，但我警告说它也不可靠。
更好的选择是 DoEvents，因为它明确设计用于处理此类事情：

DoEventspasses control to the operating system. Control is returned after the operating system has finished processing the events in its queue and all keys in the SendKeysqueue have been sent.

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

This works for me whether I run the macro manually from the IDE, from the Macros ribbon, or from a button Clickevent procedure:

无论我是从 IDE、从宏功能区还是从按钮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

How To Position, Resize & Crop the Image:

如何定位、调整大小和裁剪图像：

Regardless of which method you use, once the picture has been pasted using ActiveSheet.Pasteit will be a Shape which you can manipulate.

无论您使用哪种方法，一旦使用ActiveSheet.Paste它粘贴图片，它将成为您可以操作的形状。

To Resize:once you have a handle on the shape, just assign its Heightand Widthproperties as needed:

调整大小：一旦您拥有形状的句柄，只需根据需要分配其Height和Width属性：

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

To Position It:use the shape's TopLeftCellproperty.

定位它：使用形状的TopLeftCell属性。

To Crop It:use the shp.PictureFormat.Crop(and/or CropLeft, CropTop, CropBottom, CropRightif you need to fine-tune what part of the screenshot is needed. For instance, this crops the pasted screenshot to 800x600:

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

回答by ??c Thanh Nguy?n

You can try this code in a standard Module in Excel 32 Bit.

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

Screenshots can be captured immediately by calling Sub prcSave_Picture_Screenand it will capture your whole screen and save to the same path as your workbook (You can change the path and file name if you want)
Screenshots of an active window can also be captured after calling Sub prcSave_Picture_Active_Window3 seconds (which is adjustable)

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

Source: ms-office-forum.de

来源：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

回答by Jon Kepa Uriarte

Sub SavePicToFile(namefile)
 Selection.CopyPicture xlScreen, xlBitmap
 Application.DisplayAlerts = False
 Set tmp = Charts.Add
 On Error Resume Next
 With tmp
    .SeriesCollection(1).Delete
    .Width = Selection.Width
    .Height = Selection.Height
    .Paste
    .Export filename:=namefile, Filtername:="jpeg"
    .Delete
 End With
End Sub
foto = Application.ActiveWorkbook.Path & "\Foto" & ".jpeg"
ActiveWorkbook.Sheets(1).Range("A1:Z30").Select
SavePicToFile (foto)

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

提问by loco

回答by David Zemens

Without using `SendKeys`

不使用 `SendKeys`

Using `SendKeys`, Problem Solved:

使用`SendKeys`，问题解决：

How To Position, Resize & Crop the Image:

如何定位、调整大小和裁剪图像：

回答by ??c Thanh Nguy?n

回答by Jon Kepa Uriarte

相关推荐

最近更新

标签

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

提问by loco

回答by David Zemens

Without using SendKeys

不使用 SendKeys

Using SendKeys, Problem Solved:

使用SendKeys，问题解决：

How To Position, Resize & Crop the Image:

如何定位、调整大小和裁剪图像：

回答by ??c Thanh Nguy?n

回答by Jon Kepa Uriarte

相关推荐

Excel VBA 通过鼠标获取用户选择范围的范围

在 VBA 中查找列的最大值

如何使用 VBA 保护 Excel 工作簿？

vba 查找黄色文本的所有实例并将字体颜色更改为红色

相关推荐

最近更新

标签

Without using `SendKeys`

不使用 `SendKeys`

Using `SendKeys`, Problem Solved:

使用`SendKeys`，问题解决：