Xuất vùng in Excel dưới dạng hình ảnh

Question

Tôi có tệp Excel (xlsm) và tôi muốn xuất vùng in (ở kích thước đầy đủ) dưới dạng hình ảnh (png hoặc bất kỳ định dạng tệp hình ảnh nào khác).

Tôi có macro VBA, hoạt động tốt trên một số PC trong Excel 2013, nhưng vì chúng tôi làm việc với Excel 2016, nó chỉ xuất một hình ảnh trống.

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

Tôi thường sử dụng các chức năng dưới đây, mà nên được gọi như thế này trong trường hợp của bạn:

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 

Và các chức năng để lấy đường dẫn của hình ảnh được tạo ra:

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