Question

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

我有一个VBA宏，在Excel 2013中的几台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

将Excel打印区域导出为图像

1 个答案: