Take Screenshot in Excel VBA and save in a separate file - vba

Question

I' trying to automate the generation of small-sized screenshots directly from excel sheet by clicking a button with VBA code in the background. Here is the situation:
I have to take screenshot of cellrange G1:I12, and save it in a filename
called scrt.png. The size of the screenshot should remain exactly the same as that of cellrange G1:I12
From one of the earlier posts, I found this code which seems to work by first including the screenshot of the mentioned range to a new ChartSheet, and then it saves the scrt.png file at the mentioned location successfully. In essence, it successfully generates a bitmap of the selected cell range in the ChartSheet, and also generates the seperate scrt.png file at the mentioned location.
However, the problem with the code is that the scrt.png file that is created is having the whole ChartSheet screenshot. What I am looking for only the file saved with mentioned cell range snap.
Have tried to tweak the code, but no success. Any help will be greatly appreciated.
Sub Macro1()
myFileName = "scrt.png"
Range("G1:I12").Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Charts.Add
ActiveChart.Paste
ActiveChart.Export Filename:=ThisWorkbook.Path & "\" & myFileName, Filtername:="PNG"
End Sub
Thanks a lot.

Answer 1

Instead of using a Chart sheet, use an embedded chartObject on a regular worksheet - then you can resize it before pasting in the copied range picture
Sub Tester()
ExportRange Selection, "C:\_Stuff\test\scrt.png"
End Sub
Sub ExportRange(rng As Range, sPath As String)
Dim cob, sc
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set cob = rng.Parent.ChartObjects.Add(10, 10, 200, 200)
'remove any series which may have been auto-added...
Set sc = cob.Chart.SeriesCollection
Do While sc.Count > 0
sc(1).Delete
Loop
With cob
.Height = rng.Height
.Width = rng.Width
.Chart.Paste
.Chart.Export Filename:=sPath, Filtername:="PNG"
.Delete
End With
End Sub