VBA Excel 用于截取指定区域的屏幕截图并粘贴到 MS Excel

Question

我已经成功地抓取了屏幕并将其复制到 excel。不幸的是，它看起来像下面 link 中提供的解决方案；

对我来说不够。

我想将图像裁剪到屏幕的指定区域。

我的代码如下所示：

     Sub Screengrab()
     Application.SendKeys "({1068})", True
     DoEvents
     ActiveSheet.Paste Destination:=ActiveSheet.Range("B3")

     Dim shp As Shape
     Dim h As Single, w As Single
     With ActiveSheet
     Set shp = .Shapes(.Shapes.Count)
     End With
     h = -(675 - shp.Height)
     w = -(705 - shp.Width)
     'shp.Height = 2100
     'shp.Width = 2400
     shp.LockAspectRatio = False
     shp.PictureFormat.CropRight = w
     shp.PictureFormat.CropTop = h
    'shp.PictureFormat.offset (-5)
     End Sub

这就是正在发生的事情。
从上面的代码中，我在正确的位置获取图像，但是因为它已被裁剪，所以我得到了屏幕截图的最左侧部分，其中包括我不想要的工具栏。
我想让这个裁剪区域向右拉，这将包括工作页面而不是侧边栏。
如果我将代码更改为 shp.PictureFormat.CropLeft = w，我会得到与桌面相对的部分，这很好。我可以抱怨，但它没有出现在我的打印区域，而是很远。
我还尝试缩小屏幕截图，尽管这太棘手了，因为裁剪与指定区域不匹配。

有什么方法可以正确抵消它吗？

我尝试复制代码参数并从两侧进行裁剪，但没有用，因为图像立即消失了：

     Dim shp As Shape
     Dim h As Single, w As Single ' l As Single, r As Single
     With ActiveSheet
      Set shp = .Shapes(.Shapes.Count)
     End With
     h = -(675 - shp.Height)
     w = -(705 - shp.Width)
    'l = -(500 - shp.Height)
    'r = -(500 - shp.Width)
    'shp.Height = 2100
    'shp.Width = 2400
    shp.LockAspectRatio = False
    shp.PictureFormat.CropLeft = w
    'shp.PictureFormat.CropLeft = r
    shp.PictureFormat.CropBottom = h
    'shp.PictureFormat.CropTop = l

    End Sub

偏移选项不起作用，因为此处不支持： 'shp.PictureFormat.offset (-5) 以及：

shp.Range("B3").PasteSpecial

有什么办法可以把指定区域的截图偏移到我在工作表中的区域吗？

Answer 1

好的，看来我已经解决了这个问题。

首先，为了将我们的作物放在所需的列中，我们必须使用 VBA .Top 和 .Left 位置，这基本上相当于 "moving objects" in VBA Excel.

接下来，如果我们想从反面裁剪图像，我们需要其他变量（我已经在我之前的代码中列出，但将它们关闭）。值得一提的是，如果您输入的值不正确，那么裁剪后的图像将几乎消失——细条将出现在文档中的某处。这些变量及其值的顺序基本上很重要。例如，如果 2 个屏幕的完整屏幕截图计数为 3840 x 1080 像素，则 .CropLeft 将关闭最左侧的像素范围，即 Cropleft 1225 将消除从左侧开始计数的 1225 像素。另一方面，.Cropright 的值必须大于 1225。例如，如果此 .Cropright 计数为 1500，则将删除 1500 和 3840 之间的像素。类似地，它适用于 .CroopTop 和 .Cropbottom.

此外，我们始终可以使用 .Width 和 .Height 变量以使裁剪后的屏幕截图适合我们的工作表范围。最后一件事是 .LockAspectRatio = False，我不想将其更改为 True，因为它可能会导致从我们的屏幕上裁剪不需要的区域。相反，我建议使用 this simple tool.

手动管理宽高比

最后，我整理了我的代码，将 With 语句中的所有变量分组，看起来更整洁。

 Sub CopyScreen()

 Application.SendKeys "({1068})", True
     DoEvents
 ActiveSheet.Paste Destination:=ActiveSheet.Range("B3") ' default target cell, where the topleft corner of our WHOLE screenshot is to be pasted
     Dim shp As Shape
     Dim h As Single, w As Single, l As Single, r As Single
 With ActiveSheet
     Set shp = .Shapes(.Shapes.Count)
 End With
 With shp
     h = -(635 - shp.Height)
     w = -(1225 - shp.Width)
     l = -(715 - shp.Height)
     r = -(2860 - shp.Width)
          ' the new size ratio of our WHOLE screenshot pasted (with keeping aspect ratio)
    .Height = 1260 
    .Width = 1680 
    .LockAspectRatio = False
    With .PictureFormat
       .CropRight = r
       .CropLeft = w
       .CropTop = h
       .CropBottom = l
    End With
    With .Line 'optional image borders
      .Weight = 1
      .DashStyle = msoLineSolid
    End With
            ' Moving our cropped region to the target cell
    .Top = Range("B3").Top
    .Left = Range("B3").Left
End With

End Sub

VBA Excel 用于截取指定区域的屏幕截图并粘贴到 MS Excel

VBA Excel for capture screenshot with specified region and paste to MS Excel

excel

vba

screenshot