将Excel打印区域导出为图像

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

我有一个VBAmacros，在Excel 2013中可以正常工作，但是由于我们使用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 

并获得生成的图像path的function：

 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