save selected range as jpeg with VBA code

J

Jagat Pavasia

Active Member
Joined
Mar 9, 2015
Messages
359
Office Version
  1. 2021
Platform
  1. Windows
dear sir ,
I want to save selected range as image as jpeg.
I have VBA code but it did not work for me due to some missing in VBA code.
please help me with edit my VBA code and reply me,
thank you

code is below :


VBA Code: 
Sub pics()
Dim pic_rng As Range
Dim sh_temp As Worksheet
Dim ch_temp As Chart
Dim PicTemp As Picture
Application.ScreenUpdating = False
Set pic_rng = Worksheets("Sheet3").Range("A11:D:19")
Set sh_temp = Worksheets.Add
Charts.Add
ActiveChart.Location where:=xlLocationAsObject, Name:=sh_temp.Name
Set ch_temp = ActiveChart
pic_rng.CopyPicture appearance:=xlScreen, Format:=xlPicture
ch_temp.Paste
Set PicTemp = Selection
With ch_temp.Parent
.Width = PicTemp.Width
.Height = PicTemp.Height
End With
ch_temp.Export Filename:="C:\Users\Jagat Pavasia\Desktop\report_1.jpeg"
Application.DisplayAlerts = False
sh_temp.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("done")

End Sub
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Sort by date Sort by votes
Hi there

Try below:

VBA Code: 
Sub pics()
Dim pic_rng As Range
Dim sh_temp As Worksheet
Dim ch_temp As Chart
Dim PicTemp As Picture
Application.ScreenUpdating = False
Set pic_rng = Worksheets("Sheet3").Range("A11:D19")
Set sh_temp = Worksheets.Add
Charts.Add
ActiveChart.Location where:=xlLocationAsObject, Name:=sh_temp.Name
Set ch_temp = ActiveChart
pic_rng.CopyPicture appearance:=xlScreen, Format:=xlPicture
ch_temp.Paste
Set PicTemp = Selection
With ch_temp.Parent
.Width = PicTemp.Width
.Height = PicTemp.Height
End With
ch_temp.Export Filename:="C:\Users\Jagat Pavasia\Desktop\report_1.jpeg"
Application.DisplayAlerts = False
sh_temp.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("done")

End Sub

You had mistake at

VBA Code: 
Set pic_rng = Worksheets("Sheet3").Range("A11:D:19")


should be

VBA Code: 
Set pic_rng = Worksheets("Sheet3").Range("A11:D19")
 
Upvote 0
Jimmypop said:
Hi there

Try below:

VBA Code: 
Sub pics()
Dim pic_rng As Range
Dim sh_temp As Worksheet
Dim ch_temp As Chart
Dim PicTemp As Picture
Application.ScreenUpdating = False
Set pic_rng = Worksheets("Sheet3").Range("A11:D19")
Set sh_temp = Worksheets.Add
Charts.Add
ActiveChart.Location where:=xlLocationAsObject, Name:=sh_temp.Name
Set ch_temp = ActiveChart
pic_rng.CopyPicture appearance:=xlScreen, Format:=xlPicture
ch_temp.Paste
Set PicTemp = Selection
With ch_temp.Parent
.Width = PicTemp.Width
.Height = PicTemp.Height
End With
ch_temp.Export Filename:="C:\Users\Jagat Pavasia\Desktop\report_1.jpeg"
Application.DisplayAlerts = False
sh_temp.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("done")

End Sub

You had mistake at

VBA Code: 
Set pic_rng = Worksheets("Sheet3").Range("A11:D:19")


should be

VBA Code: 
Set pic_rng = Worksheets("Sheet3").Range("A11:D19")
Click to expand...
thank you
but still error on vba code that : Run time Error '9', subscript out of range
 
Upvote 0
Jagat Pavasia said:
thank you
but still error on vba code that : Run time Error '9', subscript out of range
Click to expand...
solved error due to sheet name i changed,
but still i can not get quality screen capture,

have any option for high resolution image ???

please suggest me
 
Upvote 0
Jagat Pavasia said:
solved error due to sheet name i changed,
but still i can not get quality screen capture,

have any option for high resolution image ???

please suggest me
Click to expand...

Try the below... just remember to update your sheet name again...

VBA Code: 
Sub pics()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim pic_rng As Range
Dim sh_temp As Worksheet
    Dim ChO As ChartObject, ExportName As String
    Dim CopyRange As Range
    Dim Pic As Picture
    Dim i As Long
Set pic_rng = Worksheets("Sheet3").Range("A11:D19")
Set sh_temp = Worksheets.Add
With ActiveSheet
        Set CopyRange = pic_rng
        If Not CopyRange Is Nothing Then
            Application.ScreenUpdating = False
            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:="C:\Users\Jagat Pavasia\Desktop\report_1.jpeg"
                ChO.Delete
                Pic.Delete
                sh_temp.Delete
            End If
        End If
    End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("done")
End Sub
 
Upvote 0
Jimmypop said:
Try the below... just remember to update your sheet name again...

VBA Code: 
Sub pics()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim pic_rng As Range
Dim sh_temp As Worksheet
    Dim ChO As ChartObject, ExportName As String
    Dim CopyRange As Range
    Dim Pic As Picture
    Dim i As Long
Set pic_rng = Worksheets("Sheet3").Range("A11:D19")
Set sh_temp = Worksheets.Add
With ActiveSheet
        Set CopyRange = pic_rng
        If Not CopyRange Is Nothing Then
            Application.ScreenUpdating = False
            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:="C:\Users\Jagat Pavasia\Desktop\report_1.jpeg"
                ChO.Delete
                Pic.Delete
                sh_temp.Delete
            End If
        End If
    End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("done")
End Sub
Click to expand...
wow.......it is working as I need, thank you so much...

can I save image file name of today's date with end "_1",

for example : 14/12/2022_1

please help me
 
Upvote 0
Jagat Pavasia said:
wow.......it is working as I need, thank you so much...

can I save image file name of today's date with end "_1",

for example : 14/12/2022_1

please help me
Click to expand...

VBA Code: 
Sub pics()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim pic_rng As Range
Dim sh_temp As Worksheet
    Dim ChO As ChartObject, ExportName As String
    Dim CopyRange As Range
    Dim Pic As Picture
    Dim i As Long
Set pic_rng = Worksheets("Sheet3").Range("A11:D19")
Set sh_temp = Worksheets.Add
With ActiveSheet
        Set CopyRange = pic_rng
        If Not CopyRange Is Nothing Then
            Application.ScreenUpdating = False
            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:="C:\Users\Jagat Pavasia\Desktop\" & Format(Now(), "yyyy-mm-dd") & "_1.jpeg"
                ChO.Delete
                Pic.Delete
                sh_temp.Delete
            End If
        End If
    End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("done")
End Sub
 
Upvote 0
Solution
Jimmypop said:
VBA Code: 
Sub pics()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim pic_rng As Range
Dim sh_temp As Worksheet
    Dim ChO As ChartObject, ExportName As String
    Dim CopyRange As Range
    Dim Pic As Picture
    Dim i As Long
Set pic_rng = Worksheets("Sheet3").Range("A11:D19")
Set sh_temp = Worksheets.Add
With ActiveSheet
        Set CopyRange = pic_rng
        If Not CopyRange Is Nothing Then
            Application.ScreenUpdating = False
            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:="C:\Users\Jagat Pavasia\Desktop\" & Format(Now(), "yyyy-mm-dd") & "_1.jpeg"
                ChO.Delete
                Pic.Delete
                sh_temp.Delete
            End If
        End If
    End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("done")
End Sub
Click to expand...
THANKSSSSSSSSSS
 
Upvote 0
You must log in or register to reply here.

Similar threads

Wil Moosa
  • Solved
Improve resolution range to pic
Replies
2
Views
445
jolivanes
jolivanes
S
  • Question
Copy Worksheet Range - Save to Desktop as JPG
Replies
1
Views
302
Joe4
Joe4
R
  • Question
VBA to Copy Multiple sheets to new workbook & save as .xlsb or .xlsx
2
Replies
16
Views
694
rahildhody
R
H
  • Solved
VBA code to alter specific range to selection
2
Replies
10
Views
327
Joe4
Joe4
S
  • Solved
VBA Code to select a variable folder path, find multiple .xls then copy same named worksheets into new workbook.
Replies
4
Views
433
SteveD01
S

Forum statistics

Threads
1,214,932
Messages
6,122,332
Members
449,077
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