Saving excel range as a picture

Question

I have an Excel sheet that has several charts and images which is used as a dashboard. I need to save the content in the area as an image. I found this code to save the area as an image:

Set sht = ActiveWorkbook.Sheets("Graphical Dashboard")
Set strRng = sht.Range("I1:AC124") ' range to be copied

strRng.CopyPicture xlScreen, xlPicture
lWidth = strRng.Width
lHeight = strRng.Height

Set Cht = sht.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)
Cht.Activate
Set oCht = Charts.Add

With oCht
    .Paste
    .Export Filename:=ThisWorkbook.Path & "\SavedRange.jpg", Filtername:="JPG"
End With

Cht.Delete

But, the problem is, although it saves an image which matches the area of the selected range, the image is blank. Additionally, it adds another sheet named 'Chart' and pastes the blank image to sheet.

Answer 1

I made this portable function that works in any scenario and has some cool features liks Zoom levels and automatic save as file dialog:

'Saves a range as image file on disc
' Parameters:
'   * rng = the range to save as image
'   * filename = File path and name of image. If ommited, a save as dialog is used. Accepted formats: .JPG, .BMP and .GIF. OPTIONAL.
'   * Zoom = Zoom to apply to the image before saving. Example: Zoom of 200 will make image twice the actual size.
' Returns: True = success
'
Public Function Save_Range_snapshot_as_image(rng As Range, Optional filename As String = "", Optional Zoom As Double = 100) As Boolean
  Dim ws As Worksheet
  Dim ChO As ChartObject
  Dim OldZoom As Single
    
    'Setup
    On Error GoTo ErrorCatch
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Set ws = rng.Worksheet
    ws.Activate
    OldZoom = ActiveWindow.Zoom
    ActiveWindow.Zoom = Zoom
    
    'Create temporary chart
    rng.CopyPicture xlScreen, xlPicture
    Set ChO = ws.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top, Width:=WorksheetFunction.Min(rng.Width + 100, 169056), Height:=rng.Height + 100)
    ChO.Activate
    With ChO.Chart
        .parent.Border.LineStyle = 0
        .Paste
        .ChartArea.Width = .Shapes(1).Width - 6
        .ChartArea.Height = .Shapes(1).Height - 6
        .Shapes(1).ScaleWidth 1, msoTrue
    End With
    
    'Save chart image to file
    If filename = "" Then
    filename = Application.GetSaveAsFilename(fileFilter:="Portable Networks Graphic (*.png),*.png, JPEG (*.jpg),*.jpg, Bitmap (*.bmp), *.bmp, GIF (*.gif), *.gif,")
        If CStr(filename) = CStr(False) Then GoTo cancel
    End If
    If ChO.Chart.Export(filename) Then Save_Range_snapshot_as_image = True

cancel:
    'Clean up
    On Error Resume Next
    ChO.Delete
    ActiveWindow.Zoom = OldZoom
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Function
ErrorCatch:
    If Err.Number = 1004 Then Resume Else Stop  'Unhandled Error occured
End Function

Answer 2

First I select the range I need to copy and use the method .CopyPicture, then I clear all current pictures out of the workbook if the type is msoPicture, then I paste the image into the worksheet in order to add it to the chart, I then add the copied picture to the chart, export it, and remove the chart when I'm finished.

Dim oCht, oChtArea, pic
Range("B2:AI5").CopyPicture
'On Error Resume Next

For Each pic In ThisWorkbook.Sheets("MonthlyRevenue").Shapes 'Deleting pics before copying next one in
    If pic.Type = msoPicture Then
        Debug.Print pic.Name
        pic.Delete
    End If
Next

With ThisWorkbook.Sheets("MonthlyRevenue").Pictures.Paste
    .Left = Range("C15").Left
    .Top = Range("C15").Top
    .Name = "monthRevPic"
End With

For Each pic In ThisWorkbook.Sheets("MonthlyRevenue").Shapes
    If pic.Type = msoPicture Then
        Debug.Print pic.Name
        pic.Copy
        'SavePicture pic, "C:\temp\tempchart.jpg"
        Set oCht = ActiveSheet.ChartObjects.Add(0, 0, pic.Width, pic.Height)
        Set oChtArea = oCht.Chart
        With oChtArea
            .Paste
            .Export ("C:\temp\tempchart.jpg")
        End With
        oCht.Delete
    End If
Next

Answer 3

Well doing whole thing VBA didn't work for me. Therefore, I have used below approach.

1. Select and copy the range from macro.

   ActiveWorkbook.Sheets("Graphical Dashboard").Activate
   Range("H80:AB121").Select
   Selection.Copy
   

2. Save the content from clipboard as an image.

   # invoke the macro
   xlapp.Application.Run("SelectRangeMacro")
   
   # save the area as a image
   im = ImageGrab.grabclipboard()
   im.save('somefile.png','PNG')
   

Answer 4

As you mentioned, excel file already contains the charts in specified range, So there is no need to add chart object Set Cht = sht.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight).

I have Tested the following code and it is working.

Private Sub Test()
Set sht = ActiveWorkbook.Sheets("Sheet1")
Set strRng = sht.Range("A1:B2") ' range to be copied
Dim oCht As Chart
strRng.CopyPicture xlScreen, xlPicture
lWidth = strRng.Width
lHeight = strRng.Height
Set oCht = Charts.Add
With oCht
    .Paste
    .Export Filename:="D:\SavedRange.jpg", Filtername:="JPG"
End With
End Sub

And if chart is not there in excel and you want to draw in VBA then you will have to set source data in Chart. .SetSourceData Source:=Sheets("Sheet1").Range("A1:B2")