T4122_Export Range To Image With High Quality

https://excel-egy.com/forum/t4122
---------------------------------

Sub Test_ExportRangeToImage()
    Dim c As Range, r As Range, p As String

    Set c = ActiveCell
    Set r = Worksheets(1).Range("D5:K20")
    p = ThisWorkbook.Path & "\" & Worksheets(1).Range("G1").Value & "_" & format(Date, "yyyy.mm.dd") & ".png"

    ExportRangeToImage r, p
    Application.Goto c
End Sub

Sub ExportRangeToImage(oRng As Range, fName As String)
    oRng.CopyPicture xlScreen, xlPicture
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Temp"

    With ActiveSheet
        .Shapes.AddChart.Select
        .Shapes("Chart 1").Width = oRng.Width
        .Shapes("Chart 1").Height = oRng.Height
        ActiveChart.Paste
        .Shapes("Chart 1").ScaleWidth 2, msoFalse, msoScaleFromTopLeft
        .Shapes("Chart 1").ScaleHeight 2, msoFalse, msoScaleFromTopLeft
        ActiveChart.Export fileName:=fName, filtername:="png"
    End With

    Application.DisplayAlerts = False
        Sheets("Temp").Delete
    Application.DisplayAlerts = True
End Sub