Vba : Save Range of Cells as Image With Criteria

[muhammad susanto]

hi all...
i'm looking for vba code to save range of cells as image in Excel (.jpg or .png format)
with step or criteria like this:
1. first macro run in active sheet (any name sheet)
2. when i click run macro show message "please, select your range.."
3. then browse location Save in....
4. i don't use image for send email
i found code but i don't know use and modified

Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
    Dim xRgPic As Range
    Dim xShape As Shape
    ThisWorkbook.Activate
    Worksheets(SheetName).Activate
    Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
    xRgPic.CopyPicture
    With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
        .Activate
        For Each xShape In ActiveSheet.Shapes
            xShape.Line.Visible = msoFalse
        Next
        .Chart.Paste
        .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
    End With
   Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub

would you help me out greatly appreciated..

.susanto

 

[alexofrhodes]

Use this.

Excel - VBA - Save Range as JPG Image | DEVelopers HUT

A VBA procedure to export an Excel Range to a JPG image file.

www.devhut.net

Image extensions can be gif, jpg, ico, bmp, cur, wmf

 

[Domenic]

Try the following macro. You'll notice that it exports the image as a PNG file, since it's more appropriate for screenshots. Change the default path and filename as desired.

Option Explicit

Sub ExportRangeToPNG()

    On Error Resume Next
    Dim userRange As Range
    Set userRange = Application.InputBox(Prompt:="Select a range to export", Title:="Select Range", Type:=8)
    If userRange Is Nothing Then
        Exit Sub
    End If
    On Error GoTo 0
 
    Dim defaultPathAndFilename As String
    defaultPathAndFilename = Application.DefaultFilePath & "\" & Replace(userRange.Address(0, 0, xlA1, 1), ":", "to") & ".png"
 
    Dim saveAsFilename As Variant
    saveAsFilename = Application.GetSaveAsFilename(InitialFileName:=defaultPathAndFilename, FileFilter:="Portable Network Graphics (*.png), *.png", Title:="Save As")
 
    If saveAsFilename = False Then Exit Sub
 
    userRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture
 
    With userRange.Parent.ChartObjects.Add(Left:=0, Top:=0, Width:=userRange.Width + 2, Height:=userRange.Height + 2)
        .Activate
        With .Chart
            .ChartArea.Format.Line.Visible = msoFalse
            .Paste
            With .Pictures(1)
                .Left = .Left + 2
                .Top = .Top + 2
            End With
            .Export CStr(saveAsFilename)
        End With
        .Delete
    End With
 
End Sub

Hope this helps!

 

[muhammad susanto]

hi Domenic...thank you so much!! working well.

 

[Domenic]

Hi Muhammad,

That's great, I'm glad I could help.

Cheers!