使用Excel VBAmacros捕获+保存特定区域在同一文件中的屏幕截图
我正在尝试创build一个使用ActiveX控件button（单击）的macros来截取我的桌面屏幕，并将其保存在与button相同的Excel表格中。 如何创build尺寸为800×600的屏幕截图（不是完整的桌面视图），然后将其粘贴到与button相同的图纸的左侧？ 我已经尝试了多种方法，包括sendkeys（最简单）。
我将捕获过程保存在一个模块中：
Sub PasteScreenShot() Application.SendKeys "({1068})" ActiveSheet.Paste End Sub 然后调用ActiveXbutton代码中的子。 捕获的作品，但我不能找出一种方法来操纵其区域抓取或粘贴在表单上的位置。
我试图自动化与button，而不是使用剪切工具。
没有使用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的调用实际上并不是粘贴在Print Screen上，而是粘贴在Clipboard队列中的任何东西上，直到你需要点击你的button来调用macros两次 。实际上会粘贴屏幕截图。
我尝试了一些不同的东西，但没有用，但忽略了一些显而易见的事情：在debugging的时候，如果我在ActiveSheet.Paste上放置一个断点，我不再看到上面描述的问题！
这告诉我， SendKeys处理速度不够快，无法在执行下一行代码之前将数据放入剪贴板，为解决这个问题，有两种可能的解决scheme。
- 你可以尝试
Application.Wait。 这个方法在我testing的时候似乎有效，但是我会提醒的是这也是不可靠的。 - 更好的select是
DoEvents，因为它明确地devise来处理这种事情：
DoEvents将控制传递给操作系统。 操作系统完成处理其队列中的事件并且SendKeys队列中的所有密钥都已发送完毕后，将返回控制权。
这适用于我是否从IDE手动运行macros，从macrosfunction区或buttonClick事件过程：
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
如何定位，resize和裁剪图像：
无论您使用哪种方法，一旦使用ActiveSheet.Paste粘贴图片，粘贴它将是一个您可以操作的形状。
resize：一旦你有形状的句柄，只需要根据需要分配其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 ，例如，将粘贴的屏幕截图CropRight为800×600：
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
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)