Excel yazdırma alanını bir görüntü olarak dışa aktarma

Question

Bir Excel dosyasına (xlsm) sahibim ve yazdırma alanını (tam boyutta) bir görüntü (png veya başka bir resim dosyası biçimi) olarak vermek istiyorum.

Excel 2013'te birkaç PC'de iyi çalışan bir VBA makrosu var, ancak Excel 2016 ile çalıştığımız için yalnızca boş bir görüntü veriyor.

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 

Genellikle sizin durumunuzda böyle çağrılmalıdır aşağıda işlevini kullanın

Answer 1

:

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