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

Question

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

Answer 1

do you want to try the below code I found on the internet somewhere many moons ago and used.
It uses the Export function of the Chart object along with the CopyPicture method of the Range object.
References:
MSDN - Export method as it applies to the Chart object. to save the clipboard as an Image
MSDN - CopyPicture method as it applies to the Range object to copy the range as a picture
dim sSheetName as string
dim oRangeToCopy as range
Dim oCht As Chart
sSheetName ="Sheet1" ' worksheet to work on
set oRangeToCopy =Range("B2:H8") ' range to be copied
Worksheets(sSheetName).Range(oRangeToCopy).CopyPicture xlScreen, xlBitmap
set oCht =charts.add
with oCht
.paste
.Export FileName:="C:\SavedRange.jpg", Filtername:="JPG"
end with

Answer 2

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

Answer 3

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

Answer 4

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/

Answer 5

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

Answer 6

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"
'##################
'Łukasz : 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"
'Łukasz: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
'Łukasz: 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

Answer 7

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")
'Add a Zoom to increase the resolution of the image.
ActiveWindow.Zoom = 300
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
'Reset Zoom to innitial zoom of the image.
ActiveWindow.Zoom = 100
End Sub

Answer 8

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

Answer 9

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