导出Excel打印区域作为图像

Question

我有一个excel文件（xlsm），我想将打印区域（全尺寸）导出为图像（png或任何其他图片文件格式）。

我有一个VBA宏，在2013年的Excel中的几台PC上都很好，但是自从我们与Excel 2016合作以来，它只会导出空白图像。

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

我通常使用以下功能，在您的情况下应这样称呼：

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

以及获取生成图像路径的功能：

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