VBA to save range as .png or jpeg

J

Jasesair

Active Member
Joined
Apr 8, 2015
Messages
282
Office Version
  1. 2016
I'm looking for a way to save a range in a sheet to a png or jpg file. Currently, I'm able to open up the Save As dialog box for a PDF, so doing the same for a PNG would be fantastic.

Below is my code for Save As PDF. Any help to Save As an image would be fantastic.

VBA Code: 
Sub SaveAsPDF()
    Application.ScreenUpdating = False
    Dim ws As Worksheet: Set ws = ActiveSheet
    With Sheets("Invoice")
        .Activate
        Application.Dialogs(xlDialogSaveAs).Show .Range("e1") & " " & .Range("b12") & " - " & .Range(" b14"), 57
    End With
    ws.Activate
End Sub
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
Sort by date Sort by votes
VBA Code: 
Option Explicit

Sub Example1()
Dim i As Integer
Dim intCount As Integer
Dim objPic As Shape
Dim objChart As Chart

'copy the range as an image
Call Sheet1.Range("A1:E12").CopyPicture(xlScreen, xlPicture)

    'remove all previous shapes in sheet2
    intCount = Sheet2.Shapes.Count
        For i = 1 To intCount
            Sheet2.Shapes.Item(1).Delete
        Next i
    'create an empty chart in sheet2
    Sheet2.Shapes.AddChart
    'activate sheet2
    Sheet2.Activate
    'select the shape in sheet2
    Sheet2.Shapes.Item(1).Select
    Set objChart = ActiveChart
    'paste the range into the chart
    objChart.Paste
    'save the chart as a JPEG
    objChart.Export ("C:\Users\gagli\Desktop\TestImage.Jpeg")
    
End Sub
 
Upvote 0
This is looking really good. Does this have to save to a location, or can it just be a Save As? I'm making a spreadsheet that can be used by multiple people, so there won't be a known file path.
 
Upvote 0
Another approach.

VBA Code: 
Sub SaveAsJPG()
    Dim ChO As ChartObject, ExportName As String
    Dim CopyRange As Range
    Dim Pic As Picture
    Dim i As Long

    'Sheets("Invoice").Activate
    With ActiveSheet
        Set CopyRange = .UsedRange
        If Not CopyRange Is Nothing Then
            Application.ScreenUpdating = False
            ExportName = Application.GetSaveAsFilename(InitialFileName:=.Range("e1") & " " & .Range("b12") & " - " & .Range("b14"), fileFilter:="JPEG Files (*.jpg), *.jpg")
            If Not ExportName = "False" Then
                CopyRange.Copy
                .Pictures.Paste
                Set Pic = .Pictures(.Pictures.Count)
                Set ChO = .ChartObjects.Add(Left:=10, Top:=10, Width:=Pic.Width, Height:=Pic.Height)
                Application.CutCopyMode = False
                Do
                    DoEvents
                    Pic.Copy
                    DoEvents
                    ChO.Chart.Paste
                    DoEvents
                    i = i + 1
                Loop Until (ChO.Chart.Shapes.Count > 0 Or i > 50)

                ChO.Chart.Export Filename:=ExportName, Filtername:="JPG"
                ChO.Delete
                Pic.Delete
            End If
            Application.ScreenUpdating = True
        End If
    End With
End Sub
 
Upvote 0
Solution
.
Saves to workbook location. Highlight range to save as JPG

VBA Code: 
Sub CopyRangeToJpg()

    Dim rng As Excel.Range
    Dim cht As Excel.ChartObject
    Dim alan As String
    Dim i As Long
   Dim strPath As String
   strPath = ThisWorkbook.Path & "\"
   
    Application.ScreenUpdating = False
    alan = Selection.Address
    For i = 1 To 1
        Set rng = Sheets(i).Range(alan)
        rng.CopyPicture xlScreen, xlPicture
        Set cht = Sheets(i).ChartObjects.Add(0, 0, rng.Width + 10, rng.Height + 10)
        cht.Chart.Paste
        cht.Chart.Export DosyaKontrolu(strPath, "myimage", ".jpg", i)
        cht.Delete
ExitProc:
        Application.ScreenUpdating = True
        Set cht = Nothing
        Set rng = Nothing
    Next

End Sub

Private Function DosyaKontrolu(DosyaYolu As String, DosyaOnEk As String, DosyaUzanti As String, Sayi As Long) As String
    Dim fso As Object
    Dim Kontrol As Boolean
    Dim TamDosyaYolu As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    With fso
        Do
            TamDosyaYolu = DosyaYolu & DosyaOnEk & Sayi & DosyaUzanti
            Kontrol = fso.FileExists(TamDosyaYolu)
            Sayi = Sayi + 1
        Loop Until Not Kontrol
        DosyaKontrolu = TamDosyaYolu
    End With
    Set fso = Nothing
End Function
 
Upvote 0
rlv01 said:
Another approach.

VBA Code: 
Sub SaveAsJPG()
    Dim ChO As ChartObject, ExportName As String
    Dim CopyRange As Range
    Dim Pic As Picture
    Dim i As Long

    'Sheets("Invoice").Activate
    With ActiveSheet
        Set CopyRange = .UsedRange
        If Not CopyRange Is Nothing Then
            Application.ScreenUpdating = False
            ExportName = Application.GetSaveAsFilename(InitialFileName:=.Range("e1") & " " & .Range("b12") & " - " & .Range("b14"), fileFilter:="JPEG Files (*.jpg), *.jpg")
            If Not ExportName = "False" Then
                CopyRange.Copy
                .Pictures.Paste
                Set Pic = .Pictures(.Pictures.Count)
                Set ChO = .ChartObjects.Add(Left:=10, Top:=10, Width:=Pic.Width, Height:=Pic.Height)
                Application.CutCopyMode = False
                Do
                    DoEvents
                    Pic.Copy
                    DoEvents
                    ChO.Chart.Paste
                    DoEvents
                    i = i + 1
                Loop Until (ChO.Chart.Shapes.Count > 0 Or i > 50)

                ChO.Chart.Export Filename:=ExportName, Filtername:="JPG"
                ChO.Delete
                Pic.Delete
            End If
            Application.ScreenUpdating = True
        End If
    End With
End Sub
Click to expand...
This works well. Any idea how I can adjust it so it does an image of a select range? Currently, this is doing everything in the worksheet.
 
Upvote 0
Logit said:
.
Saves to workbook location. Highlight range to save as JPG

VBA Code: 
Sub CopyRangeToJpg()

    Dim rng As Excel.Range
    Dim cht As Excel.ChartObject
    Dim alan As String
    Dim i As Long
   Dim strPath As String
   strPath = ThisWorkbook.Path & "\"
  
    Application.ScreenUpdating = False
    alan = Selection.Address
    For i = 1 To 1
        Set rng = Sheets(i).Range(alan)
        rng.CopyPicture xlScreen, xlPicture
        Set cht = Sheets(i).ChartObjects.Add(0, 0, rng.Width + 10, rng.Height + 10)
        cht.Chart.Paste
        cht.Chart.Export DosyaKontrolu(strPath, "myimage", ".jpg", i)
        cht.Delete
ExitProc:
        Application.ScreenUpdating = True
        Set cht = Nothing
        Set rng = Nothing
    Next

End Sub

Private Function DosyaKontrolu(DosyaYolu As String, DosyaOnEk As String, DosyaUzanti As String, Sayi As Long) As String
    Dim fso As Object
    Dim Kontrol As Boolean
    Dim TamDosyaYolu As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    With fso
        Do
            TamDosyaYolu = DosyaYolu & DosyaOnEk & Sayi & DosyaUzanti
            Kontrol = fso.FileExists(TamDosyaYolu)
            Sayi = Sayi + 1
        Loop Until Not Kontrol
        DosyaKontrolu = TamDosyaYolu
    End With
    Set fso = Nothing
End Function
Click to expand...
Unfortunately I'm unable to get this to do anything at all. I added the whole lot to a module - perhaps this is wrong. Also, is there a way to have a set range rather than manually highlighting a range?
 
Upvote 0
.
VBA Code: 
Sub CopyRangeToJpg2()

    Dim rng As Excel.Range
    Dim cht As Excel.ChartObject
    'Dim alan As String
    Dim i As Long
   Dim strPath As String
   strPath = ThisWorkbook.Path & "\"
  
    Application.ScreenUpdating = False
    'alan = Selection.Address
    For i = 1 To 1
        Set rng = ActiveSheet.Range("A1:D19")
        rng.CopyPicture xlScreen, xlPicture
        Set cht = Sheets(i).ChartObjects.Add(0, 0, rng.Width + 10, rng.Height + 10)
        cht.Chart.Paste
        cht.Chart.Export DosyaKontrolu(strPath, "myimage", ".jpg", i)
        cht.Delete
ExitProc:
        Application.ScreenUpdating = True
        Set cht = Nothing
        Set rng = Nothing
    Next

End Sub

Private Function DosyaKontrolu(DosyaYolu As String, DosyaOnEk As String, DosyaUzanti As String, Sayi As Long) As String
    Dim fso As Object
    Dim Kontrol As Boolean
    Dim TamDosyaYolu As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    With fso
        Do
            TamDosyaYolu = DosyaYolu & DosyaOnEk & Sayi & DosyaUzanti
            Kontrol = fso.FileExists(TamDosyaYolu)
            Sayi = Sayi + 1
        Loop Until Not Kontrol
        DosyaKontrolu = TamDosyaYolu
    End With
    Set fso = Nothing
End Function
 
Upvote 0
Jasesair said:
This works well. Any idea how I can adjust it so it does an image of a select range? Currently, this is doing everything in the worksheet.
Click to expand...
I set it up to act on the whole worksheet because that is what the sample code you posted does. This line in my posted code:

VBA Code: 
      Set CopyRange = .UsedRange

Controls the range, so if you can change it to :

VBA Code: 
 Set CopyRange = Selection

It should work, though I have not tested it.
 
Upvote 0
This came up just now in my search, so when I modified the code I decided to update the thread. File will be saved to the user document folder with yyyymmdd hhmmss.png name

VBA Code: 
Option Explicit

Sub SelectedRangeToFile()

    Dim objChart As Chart
    Dim strFileName As String
    Dim sSaveDir As String
    Dim ser As Series
    Dim varCount As Variant
    
    varCount = Selection.Cells.CountLarge
    If varCount > 2000 Then  'Picked 2K as upper limit for single page
        Select Case MsgBox(">2K cells selected.  Continue ? ", vbOKCancel)
        Case vbCancel
            GoTo End_Sub
        End Select
    End If
    
    sSaveDir = Environ("userprofile") & "\Documents\"
    strFileName = ActiveSheet.Name & Format(Now(), " yyyymmdd hhmmss")
    
    'copy the range as an image
    Call Selection.CopyPicture(xlScreen, xlPicture)

    'Add chart and remove any series
    Charts.Add2
    Set objChart = ActiveChart
    For Each ser In objChart.SeriesCollection
        ser.Delete
    Next
    
    'paste the range into the chart
    objChart.Paste
    
    'save the chart as a PNG
    objChart.Export Filename:=sSaveDir & strFileName & ".png", Filtername:="PNG"
    
    DoEvents 'to give the chart time to save
    
    'Delete the chart
    Application.DisplayAlerts = False
    objChart.Delete
    Application.DisplayAlerts = True

End_Sub:
    
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question
Opening link and saving as pdf
Replies
0
Views
398
lizemi
L
A
  • Solved
3 way use button to run macro
Replies
2
Views
75
Aleytha
A
C
  • Question
Change from Save As Excel file to Save As PDF
Replies
1
Views
530
bobsan42
bobsan42
I
  • Question
Inoice number not being saved in cell
Replies
6
Views
298
ipbr21054
I
M
  • Question
Excel VBA Save PDF within workbook folder and send as email attachment
Replies
1
Views
227
rpaulson
rpaulson

Forum statistics

Threads
1,214,927
Messages
6,122,311
Members
449,080
Latest member
jmsotelo

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top