Export Excel printable area as image

Question

I have an Excel file (xlsm) and I would like to export the print area (full size) as an image (png or any other image file format).

I have a VBA macro that worked fine on multiple PCs in Excel 2013, but since we are working with Excel 2016, it only exports a blank image.

Sub pic_save() Worksheets("Sheet1").Select Set Sheet = ActiveSheet output = C:\pic.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 End Sub 

Answer 1

I usually use the following function, which should be called in your case like this:

 Sub pic_save() Dim PicPath As String Dim OutPutPath As String Dim wS As Worksheet Set wS = ThisWorkbook.Sheets("Sheet1") OutPutPath = "C:\" PicPath = Generate_Image_From_Range(wS, wS.Range(wS.PageSetup.PrintArea).Address, OutPutPath, "pic", "png", False) MsgBox wS.Name & " exported to : " & vbCrLf & _ PicPath, vbInformation + vbOKOnly End Sub 

And the function to get the path to the generated image:

 Public Function Generate_Image_From_Range(wS As Worksheet, _ RgStr As String, _ OutPutPath As String, _ ImgName As String, _ ImgType As String, _ Optional TrueToTuneFilters As Boolean = False) As String Dim ImgPath As String Dim oRng As Range Dim oChrtO As ChartObject Dim lWidth As Long, lHeight As Long Dim ActSh As Worksheet Dim ValScUp As Boolean ImgPath = OutPutPath & ImgName & "." & ImgType Set ActSh = ActiveSheet Set oRng = wS.Range(RgStr) wS.Activate 'On Error GoTo ErrHdlr With oRng .Select '''Zoom to improve render ValScUp = Application.ScreenUpdating Application.ScreenUpdating = False ActiveWindow.Zoom = True DoEvents Application.ScreenUpdating = ValScUp lWidth = .Width lHeight = .Height .CopyPicture xlScreen, xlPicture 'Best render End With 'oRng Set oChrtO = wS.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight) With oChrtO .Activate .Chart.Paste With .ShapeRange .Line.Visible = msoFalse .Fill.Visible = msoFalse With .Chart.Shapes.Item(1) .Line.Visible = msoFalse .Fill.Visible = msoFalse End With '.Chart.Shapes.Item (1) End With '.ShapeRange With .Chart DoEvents If Not TrueToTuneFilters Then _ .Export filename:=ImgPath, Filtername:=ImgType, Interactive:=False If TrueToTuneFilters Then _ .Export filename:=ImgPath, Filtername:=ImgType, Interactive:=True End With '.Chart DoEvents .Delete End With 'oChrtO ActSh.Activate Generate_Image_From_Range = ImgPath On Error GoTo 0 Exit Function ErrHdlr: Generate_Image_From_Range = vbNullString End Function