Saturday, April 20, 2019

To Save Ranges as picture

To Save Ranges as picture

Note: Sometimes is not working with another excel version

'Option Explicit
Private Sub SaveRngAsJPG(rng As Range, FileName As String)
On Error Resume Next
    Dim Cht As Chart, bScreen As Boolean, Shp As Shape
    bScreen = Application.ScreenUpdating
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = False
    Set Cht = Workbooks.Add(xlChart).Charts(1)
    Cht.ChartArea.Clear
    rng.CopyPicture xlScreen, xlPicture
    Cht.Paste
    With Cht.Shapes(1)
        .Left = 0
        .Top = 0
        .Width = Cht.ChartArea.Width
        .Height = Cht.ChartArea.Height
    End With
    Cht.Export FileName, "JPEG", False
    Cht.Parent.Close False
   Application.ScreenUpdating = False
   

End Sub

Sub TestIt1()

    Dim rng As Range, Fn As String, s As String
   
Application.Calculation = xlCalculationAutomatic
    Set rng = Sheets("Payslip").Range("b14:e39")
    Fn = Sheets("Payslip").Range("b10").Value
    s = Sheets("Payslip").Range("g19").Value
   
 
   
    SaveRngAsJPG rng, Fn & "Payslip " & s
End Sub

No comments:

Post a Comment