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

Question

I have managed with screengrabbing and copying it into excel. Unfortunately it looks like the solution presented in the link below;

Using Excel VBA Macro To Capture + Save Screenshot of Specific Area In Same File

is not enough for me.

I want to have the image cropped to the specified region of my screen.

My code looks like this:

     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

Here is what exactly is happening.
From the code above I am getting the image in the right place, however because it has been cropped I got the leftmost part of the screenshot, which includes the toolbar, which I don't want.
I want to have this cropped region pulled towards right, which would include the workpage instead of side bar.
If I change the code to shp.PictureFormat.CropLeft = wi am getting somewhat an opposite part of the desktop, which is good. I could,t complain but it doesn't appear in my printing area, but far away.
I tried also to make the screenshot smaller, although it's too tricky, as the crop doesn't match to the area specified.

Is it some way to offset it properly?

I tried to duplicate the code parameters and do the crops from both sides, but it wasn't work, as the image was gone instantly:

     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

The offset option doesn't work, because is not supported here: 'shp.PictureFormat.offset (-5) as well as:

shp.Range("B3").PasteSpecial

Is there any way to make the screenshot from the specified region and offset it into my area in the worksheet?

Answer 1

Ok, It looks like I have managed with this problem.

First of all, in order to place our crop in the desired column, we must use the VBA .Top and .Left location, which basically works as "moving objects" in VBA Excel.

Next, if we want to crop the image from the opposite sides, we need other variables (which I already listed in my previous code, but switched them off). It's worth to know, that if you put the values incorrectly, then your cropped image will be almost gone - the thin bar will appear somewhere in the document. Basically the order of these variables and their values is important. If for instance the full screenshot from 2 screens count 3840 x 1080 px, then .CropLeft will switch off the leftmost pixels range, i.e Cropleft 1225 will eliminate the 1225 pixels counting from left. In the other hand .Cropright must have value bigger than 1225. If for example this .Cropright will count 1500, then the pixels between 1500 and 3840 will be removed. Analogically it works for .CroopTop and .Cropbottom.

Additionally, we can always use the .Width and .Height variables in order to suit the cropped screenshot to our worksheet range. The last thing is .LockAspectRatio = False, which I would rather not change to True because it might result unwanted region cropped from our screen. Instead of it I would advise to manage with the aspect ratio manually, using i.e this simple tool.

Finally, I tidied up my code, grouping all the variables in the With statements, what looks neater.

 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