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

xxhby3vn 于 2023-05-30 发布在其他

关注(0)|答案(1)|浏览(872)

我已经设法与screengrabbing和复制到excel。不幸的是，它看起来像下面的链接中提出的解决方案;
Using Excel VBA Macro To Capture + Save Screenshot of Specific Area In Same File
对我来说还不够
我想把图像裁剪到屏幕的指定区域。
我的代码看起来像这样：

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

有没有办法从指定的区域进行截图，并将其偏移到工作表中我的区域？

excel

来源：https://stackoverflow.com/questions/61754116/vba-excel-for-capture-screenshot-with-specified-region-and-paste-to-ms-excel

1条答案

按热度按时间

pxiryf3j1#

看起来我已经解决了这个问题。
首先，为了将我们的作物放置在所需的列中，我们必须使用VBA .Top和.Left位置，基本上相当于"moving objects" in VBA Excel。
接下来，如果我们想从反面裁剪图像，我们需要其他变量（我已经在前面的代码中列出了这些变量，但将其关闭）。值得一提的是，如果你输入的值不正确，那么你裁剪的图像几乎会消失--细条会出现在文档的某个地方。基本上，这些变量及其值的顺序很重要。例如，如果2个屏幕的完整屏幕截图计数为3840 x 1080 px，则.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

赞(0）回复(0）举报 2023-05-30

我来回答

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

1条答案

相关问题

热门标签

最新问答