Using VBA code, how to export Excel sheets as image in Excel 2003?

Question

Please suggest the best way to export a range of data from Excel tables as an image in .jpeg or .png format or .gif.

Answer 1

You want to try the code below, which I found on the Internet some years ago and used.

It uses the export function of the Chart object along with the CopyPicture method of the Range object.

References:

• MSDN is the export method applicable to the Chart object. to save clipboard as image

• MSDN - CopyPicture method applicable to a Range object to copy a range as an image

  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 tried to improve this solution in several ways. Now the resulting image has the correct 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 slightly modified Winand code to export it to the user's desktop, regardless of who uses the worksheet. I gave credit in the code 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 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 a problem 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

Based on the link provided by Philip, I got this to work

 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 6

 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 7

Solution without diagrams

 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 8

If you add a selection and save path to the book to Ryan Bradley's code, which 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 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