[vba] Using VBA code, how to export Excel worksheets as image in Excel 2003?

Please suggest the better way of exporting range of data from excel worksheets as image either in .jpeg or .png or in .gif.

There's a more direct way to export a range image to a file, without the need to create a temporary chart. It makes use of PowerShell to save the clipboard as a .png file.

Copying the range to the clipboard as an image is straightforward, using the vba CopyPicture command, as shown in some of the other answers.

A PowerShell script to save the clipboard requires only two lines, as noted by thom schumacher in Save Image from clipboard using PowerShell.

VBA can launch a PowerShell script and wait for it to complete, as noted by Asam in Wait for shell command to complete.

Putting these ideas together, we get the following routine. I've tested this only under Windows 10 using the Office 2010 version of Excel. Note that there's an internal constant AidDebugging which can be set to True to provide additional feedback about the execution of the routine.

Option Explicit

' This routine copies the bitmap image of a range of cells to a .png file.
' Input arguments:
'    RangeRef -- the range to be copied. This must be passed as a range object, not as the name
'                or address of the range.
'    Destination -- the name (including path if necessary) of the file to be created, ending in
'                the extension ".png". It will be overwritten without warning if it exists.
'    TempFile -- the name (including path if necessary) of a temporary script file which will be
'                created and destroyed. If this is not supplied, file "RangeToPNG.ps1" will be
'                created in the default folder. If AidDebugging is set to True, then this file
'                will not be deleted, so it can be inspected for debugging.
' If the PowerShell script file cannot be launched, then this routine will display an error message.
' However, if the script can be launched but cannot create the resulting file, this script cannot
' detect that. To diagnose the problem, change AidDebugging from False to True and inspect the
' PowerShell output, which will remain in view until you close its window.

Public Sub RangeToPNG(RangeRef As Range, Destination As String, _
                      Optional TempFile As String = "RangeToPNG.ps1")
Dim WSH As Object
Dim PSCommand As String
Dim WindowStyle As Integer
Dim ErrorCode As Integer
Const WaitOnReturn = True
Const AidDebugging = False ' provide extra feedback about this routine's execution
  ' Create a little PowerShell script to save the clipboard as a .png file
  ' The script is based on a version found on September 13, 2020 at
  '    https://stackoverflow.com/questions/55215482/save-image-from-clipboard-using-powershell
   Open TempFile For Output As #1
   If (AidDebugging) Then ' output some extra feedback
      Print #1, "Set-PSDebug -Trace 1" ' optional -- aids debugging
   End If
   Print #1, "$img = get-clipboard -format image"
   Print #1, "$img.save(""" & Destination & """)"
   If (AidDebugging) Then ' leave the PowerShell execution record on the screen for review
      Print #1, "Read-Host -Prompt ""Press <Enter> to continue"" "
      WindowStyle = 1 ' display window to aid debugging
   Else
      WindowStyle = 0 ' hide window
   End If
   Close #1
  ' Copy the desired range of cells to the clipboard as a bitmap image
   RangeRef.CopyPicture xlScreen, xlBitmap
  ' Execute the PowerShell script
   PSCommand = "POWERSHELL.exe -ExecutionPolicy Bypass -file """ & TempFile & """ "
   Set WSH = VBA.CreateObject("WScript.Shell")
   ErrorCode = WSH.Run(PSCommand, WindowStyle, WaitOnReturn)
   If (ErrorCode <> 0) Then
      MsgBox "The attempt to run a PowerShell script to save a range " & _
             "as a .png file failed -- error code " & ErrorCode
   End If
   If (Not AidDebugging) Then
     ' Delete the script file, unless it might be useful for debugging
      Kill TempFile
   End If
End Sub

' Here's an example which tests the routine above.
Sub Test()
   RangeToPNG Worksheets("Sheet1").Range("A1:F13"), "E:\Temp\ExportTest.png"
End Sub

Based on the link provided by Philip I got this to working

Worksheets("Final Analysis Sheet").Range("A4:G112").CopyPicture xlScreen, xlBitmap

    Application.DisplayAlerts = False
    Set oCht = Charts.Add
    With oCht
        .Paste
        .Export Filename:="C:\FTPDailycheck\TodaysImages\SavedRange.jpg", Filtername:="JPG"
        .Delete
    End With

If you add a Selection and saving to workbook path to Ryan Bradley code that will be more elastic:

 Sub ExportImage()

Dim sheet, zoom_coef, area, chartobj
Dim sFilePath As String
Dim sView As String

'Captures current window view
sView = ActiveWindow.View

'Sets the current view to normal so there are no "Page X" overlays on the image
ActiveWindow.View = xlNormalView

'Temporarily disable screen updating
Application.ScreenUpdating = False

Set sheet = ActiveSheet

'Set the file path to export the image to the user's desktop
'I have to give credit to Kyle for this solution, found it here:
'http://stackoverflow.com/questions/17551238/vba-how-to-save-excel-workbook-to-desktop-regardless-of-user
'sFilePath = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & ActiveSheet.Name & ".png"

'##################
'Lukasz : Save to  workbook directory
'Asking for filename insted of ActiveSheet.Name is also good idea, without file extension
dim FileID as string
FileID=inputbox("Type a file name","Filename...?",ActiveSheet.Name)
sFilePath = ThisWorkbook.Path & "\" & FileID & ".png"

'Lukasz:Change code to use Selection
'Simply select what you want to export and run the macro
'ActiveCell should be: Top Left 
'it means select from top left corner to right bottom corner

Dim r As Long, c As Integer, ar As Long, ac As Integer

    r = Selection.rows.Count
    c = Selection.Columns.Count
    ar = ActiveCell.Row
    ac = ActiveCell.Column
    ActiveSheet.PageSetup.PrintArea = Range(Cells(ar, ac), Cells(ar, ac)).Resize(r, c).Address

'Export print area as correctly scaled PNG image, courtasy of Winand
'Lukasz: zoom_coef can be constant = 0 to 5 can work too, but save is 0 to 4
zoom_coef = 5 '100 / sheet.Parent.Windows(1).Zoom
'#############
Set area = sheet.Range(sheet.PageSetup.PrintArea)
area.CopyPicture xlPrinter  'xlBitmap '
Set chartobj = sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
chartobj.Chart.Paste
chartobj.Chart.Export sFilePath, "png"
chartobj.Delete

'Returns to the previous view
ActiveWindow.View = sView

'Re-enables screen updating
Application.ScreenUpdating = True

'Tells the user where the image was saved
MsgBox ("Export completed! The file can be found here: :" & Chr(10) & Chr(10) & sFilePath)
'Close
End Sub

Winand, Quality was also an issue for me so I did this:

For Each ws In ActiveWorkbook.Worksheets
    If ws.PageSetup.PrintArea <> "" Then
        'Reverse the effects of page zoom on the exported image
        zoom_coef = 100 / ws.Parent.Windows(1).Zoom
        areas = Split(ws.PageSetup.PrintArea, ",")
        areaNo = 0
        For Each a In areas
            Set area = ws.Range(a)
            ' Change xlPrinter to xlScreen to see zooming white space
            area.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
            Set chartobj = ws.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
            chartobj.Chart.Paste
            'scale the image before export
            ws.Shapes(chartobj.Index).ScaleHeight 3, msoFalse, msoScaleFromTopLeft
            ws.Shapes(chartobj.Index).ScaleWidth 3, msoFalse, msoScaleFromTopLeft
            chartobj.Chart.Export ws.Name & "-" & areaNo & ".png", "png"
            chartobj.delete
            areaNo = areaNo + 1
        Next
    End If
Next

See here:https://robp30.wordpress.com/2012/01/11/improving-the-quality-of-excel-image-export/

Thanks everyone! I modified Winand's code slightly to export it to the user's desktop, no matter who is using the worksheet. I gave credit in the code to where I got the idea (thanks Kyle).

Sub ExportImage()


Dim sFilePath As String
Dim sView As String

'Captures current window view
sView = ActiveWindow.View

'Sets the current view to normal so there are no "Page X" overlays on the image
ActiveWindow.View = xlNormalView

'Temporarily disable screen updating
Application.ScreenUpdating = False

Set Sheet = ActiveSheet

'Set the file path to export the image to the user's desktop
'I have to give credit to Kyle for this solution, found it here:
'http://stackoverflow.com/questions/17551238/vba-how-to-save-excel-workbook-to-desktop-regardless-of-user
sFilePath = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & ActiveSheet.Name & ".png"

'Export print area as correctly scaled PNG image, courtasy of Winand
zoom_coef = 100 / Sheet.Parent.Windows(1).Zoom
Set area = Sheet.Range(Sheet.PageSetup.PrintArea)
area.CopyPicture xlPrinter
Set chartobj = Sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
chartobj.Chart.Paste
chartobj.Chart.Export sFilePath, "png"
chartobj.Delete

'Returns to the previous view
ActiveWindow.View = sView

'Re-enables screen updating
Application.ScreenUpdating = True

'Tells the user where the image was saved
MsgBox ("Export completed! The file can be found here:" & Chr(10) & Chr(10) & sFilePath)

End Sub

Solution without charts

Function SelectionToPicture(nome)

'save location ( change if you want )
FName = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & nome & ".jpg"

'copy selection and get size
Selection.CopyPicture xlScreen, xlBitmap
w = Selection.Width
h = Selection.Height



With ThisWorkbook.ActiveSheet

    .Activate

    Dim chtObj As ChartObject
    Set chtObj = .ChartObjects.Add(100, 30, 400, 250)
    chtObj.Name = "TemporaryPictureChart"

    'resize obj to picture size
    chtObj.Width = w
    chtObj.Height = h

    ActiveSheet.ChartObjects("TemporaryPictureChart").Activate
    ActiveChart.Paste

    ActiveChart.Export FileName:=FName, FilterName:="jpg"

    chtObj.Delete

End With
End Function

I've tried to improve this solution in several ways. Now resulting image has right proportions.

Set sheet = ActiveSheet
output = "D:\SavedRange4.png"

zoom_coef = 100 / sheet.Parent.Windows(1).Zoom
Set area = sheet.Range(sheet.PageSetup.PrintArea)
area.CopyPicture xlPrinter
Set chartobj = sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
chartobj.Chart.Paste
chartobj.Chart.Export output, "png"
chartobj.Delete

This gives me the most reliable results:

Sub RangeToPicture()
  Dim FileName As String: FileName = "C:\file.bmp"
  Dim rPrt As Range: Set rPrt = ThisWorkbook.Sheets("Sheet1").Range("A1:C6")

  Dim chtObj As ChartObject
  rPrt.CopyPicture xlScreen, xlBitmap
  Set chtObj = ActiveSheet.ChartObjects.Add(1, 1, rPrt.Width, rPrt.Height)
  chtObj.Activate
  ActiveChart.Paste
  ActiveChart.Export FileName
  chtObj.Delete
End Sub