Excel-Druckbereich als Bild exportieren

Question

Ich habe eine Excel-Datei (xlsm) und ich möchte den Druckbereich (in voller Größe) als Bild (PNG oder ein anderes Bilddateiformat) exportieren.

Ich habe ein VBA-Makro, das auf mehreren PCs in Excel 2013 funktionierte, aber da wir mit Excel 2016 arbeiten, exportiert es nur ein leeres Bild.

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

ich die unten Funktion verwenden in der Regel, die wie dies in Ihrem Fall genannt werden sollen:

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 

und die Funktion, um den Pfad des erzeugten Bildes zu erhalten:

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