Export Excel print area as an image

Question

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

I have a VBA macro, that worked fine on several PC’s in Excel 2013, but since we work 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 generally use the below function, that should be called like this in your case :

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 of 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
            .Export filename:=ImgPath, Filtername:=ImgType, Interactive:=TrueToTuneFilters 
'            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