This is an interesting approach to export a range of cells into picture using chart object.
An article that I need to utilize to create function from it in the near future.
Originally found on theSpreadsheetguru ...
https://www.thespreadsheetguru.com/blog/vba-save-as-picture-file-excel
Sub SaveShapeAsPicture()
'PURPOSE: Save a selected shape/icon as a PNG file to computer's desktop
'SOURCE: www.thespreadsheetguru.com
Dim cht As ChartObject
Dim ActiveShape As Shape
Dim UserSelection As Variant
'Ensure a Shape is selected
On Error GoTo NoShapeSelected
Set UserSelection = ActiveWindow.Selection
Set ActiveShape = ActiveSheet.Shapes(UserSelection.Name)
On Error GoTo 0
'Create a temporary chart object (same size as shape)
Set cht = ActiveSheet.ChartObjects.Add( _
Left:=ActiveCell.Left, _
Width:=ActiveShape.Width, _
Top:=ActiveCell.Top, _
Height:=ActiveShape.Height)
'Format temporary chart to have a transparent background
cht.ShapeRange.Fill.Visible = msoFalse
cht.ShapeRange.Line.Visible = msoFalse
'Copy/Paste Shape inside temporary chart
ActiveShape.Copy
cht.Activate
ActiveChart.Paste
'Save chart to User's Desktop as PNG File
cht.Chart.Export Environ("USERPROFILE") & "\Desktop\" & ActiveShape.Name & ".png"
'Delete temporary Chart
cht.Delete
'Re-Select Shape (appears like nothing happened!)
ActiveShape.Select
Exit Sub
'ERROR HANDLERS
NoShapeSelected:
MsgBox "You do not have a single shape selected!"
Exit Sub
End Sub
Sub SaveRangeAsPicture()
'PURPOSE: Save a selected cell range as a JPG file to computer's desktop
'SOURCE: www.thespreadsheetguru.com
Dim cht As ChartObject
Dim ActiveShape As Shape
'Confirm if a Cell Range is currently selected
If TypeName(Selection) < > "Range" Then
MsgBox "You do not have a single shape selected!"
Exit Sub
End If
'Copy/Paste Cell Range as a Picture
Selection.Copy
ActiveSheet.Pictures.Paste(link:=False).Select
Set ActiveShape = ActiveSheet.Shapes(ActiveWindow.Selection.Name)
'Create a temporary chart object (same size as shape)
Set cht = ActiveSheet.ChartObjects.Add( _
Left:=ActiveCell.Left, _
Width:=ActiveShape.Width, _
Top:=ActiveCell.Top, _
Height:=ActiveShape.Height)
'Format temporary chart to have a transparent background
cht.ShapeRange.Fill.Visible = msoFalse
cht.ShapeRange.Line.Visible = msoFalse
'Copy/Paste Shape inside temporary chart
ActiveShape.Copy
cht.Activate
ActiveChart.Paste
'Save chart to User's Desktop as PNG File
cht.Chart.Export Environ("USERPROFILE") & "\Desktop\" & ActiveShape.Name & ".jpg"
'Delete temporary Chart
cht.Delete
ActiveShape.Delete
'Re-Select Shape (appears like nothing happened!)
ActiveShape.Select
End Sub
'PURPOSE: Save a selected shape/icon as a PNG file to computer's desktop
'SOURCE: www.thespreadsheetguru.com
Dim cht As ChartObject
Dim ActiveShape As Shape
Dim UserSelection As Variant
'Ensure a Shape is selected
On Error GoTo NoShapeSelected
Set UserSelection = ActiveWindow.Selection
Set ActiveShape = ActiveSheet.Shapes(UserSelection.Name)
On Error GoTo 0
'Create a temporary chart object (same size as shape)
Set cht = ActiveSheet.ChartObjects.Add( _
Left:=ActiveCell.Left, _
Width:=ActiveShape.Width, _
Top:=ActiveCell.Top, _
Height:=ActiveShape.Height)
'Format temporary chart to have a transparent background
cht.ShapeRange.Fill.Visible = msoFalse
cht.ShapeRange.Line.Visible = msoFalse
'Copy/Paste Shape inside temporary chart
ActiveShape.Copy
cht.Activate
ActiveChart.Paste
'Save chart to User's Desktop as PNG File
cht.Chart.Export Environ("USERPROFILE") & "\Desktop\" & ActiveShape.Name & ".png"
'Delete temporary Chart
cht.Delete
'Re-Select Shape (appears like nothing happened!)
ActiveShape.Select
Exit Sub
'ERROR HANDLERS
NoShapeSelected:
MsgBox "You do not have a single shape selected!"
Exit Sub
End Sub
Sub SaveRangeAsPicture()
'PURPOSE: Save a selected cell range as a JPG file to computer's desktop
'SOURCE: www.thespreadsheetguru.com
Dim cht As ChartObject
Dim ActiveShape As Shape
'Confirm if a Cell Range is currently selected
If TypeName(Selection) < > "Range" Then
MsgBox "You do not have a single shape selected!"
Exit Sub
End If
'Copy/Paste Cell Range as a Picture
Selection.Copy
ActiveSheet.Pictures.Paste(link:=False).Select
Set ActiveShape = ActiveSheet.Shapes(ActiveWindow.Selection.Name)
'Create a temporary chart object (same size as shape)
Set cht = ActiveSheet.ChartObjects.Add( _
Left:=ActiveCell.Left, _
Width:=ActiveShape.Width, _
Top:=ActiveCell.Top, _
Height:=ActiveShape.Height)
'Format temporary chart to have a transparent background
cht.ShapeRange.Fill.Visible = msoFalse
cht.ShapeRange.Line.Visible = msoFalse
'Copy/Paste Shape inside temporary chart
ActiveShape.Copy
cht.Activate
ActiveChart.Paste
'Save chart to User's Desktop as PNG File
cht.Chart.Export Environ("USERPROFILE") & "\Desktop\" & ActiveShape.Name & ".jpg"
'Delete temporary Chart
cht.Delete
ActiveShape.Delete
'Re-Select Shape (appears like nothing happened!)
ActiveShape.Select
End Sub
Not tested yet
Views 798
Downloads 500
CodeID
DB ID
ANmarAmdeen
610
Revisions
v2.0
Monday
December
21
2020