Take Screenshot in Excel VBA and save in a separate file

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