VBA saving images

Hillsy7

New Member
Joined
Jun 17, 2014
Messages
25
Please god someone tell me this is possible somehow.

I'm making a deck of Trading card Game cards and - hey! - in excel versions gone by you could create an image, and save it as a jpg. So I've got a spreadsheet for autopoulating about 500 of these with relevant information. All works great - go me.

However I'm going mental trying to save the newly created image as a jpg/png/whatever in Excel 2016...I can save it from word, or powerpoint - but I've got 500 of these and I don't want to have to do them all manually.

Can anyone help, please!
 

Some videos you may like

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying

rpaulson

Well-known Member
Joined
Oct 4, 2007
Messages
1,143
try this,
set range and path as needed.

Code:
Option Explicit

Private Sub SaveRngAsJPG(Rng As Range, FileName As String)
    Dim Cht As Chart, bScreen As Boolean, Shp As Shape
    bScreen = Application.ScreenUpdating
    Application.ScreenUpdating = False
    Set Cht = Workbooks.Add(xlChart).Charts(1)
    Cht.ChartArea.Clear
    Rng.CopyPicture xlScreen, xlPicture
    Cht.Paste
    With Cht.Shapes(1)
        .Left = 0
        .Top = 0
        .Width = Cht.ChartArea.Width
        .Height = Cht.ChartArea.Height
    End With
    Cht.Export FileName, "JPEG", False
    Cht.Parent.Close False
    Application.ScreenUpdating = bScreen
End Sub

Sub TestIt2()
    Dim Rng As Range, Fn As String
    Set Rng = Range("A1:H21")
    Fn = "C:\results\MyFile.jpg"
    SaveRngAsJPG Rng, Fn
End Sub

hth,
Ross
 

byundt

New Member
Joined
Mar 26, 2005
Messages
6
I don't know if the issue is specific to my install of 64-bit Excel 2016/Office365, but rpaulson's code gave me consistent errors at With Cht.Shapes(1). The remedies were two-fold: adding a DoEvents statement above Cht.Paste, and commenting out the part turning off screen updating.

I also had issues with the image being truncated. The remedies were to preserve the aspect ratio, set the image width or height (but not both), set the image control to align the image at top left, and set the image control to zoom.

The code below shows how I adjusted rpaulson's code to work on my computer, with examples of displaying a range, picture on a worksheet, and chart on a worksheet in the userform imagecontrol. There is an annoying bit of screen flashing when the code runs, but it doesn't give me a runtime error.
Code:
Sub LoadPictureToImageControl(flPathName As String, ImageControl As Control)
    ImageControl.Picture = LoadPicture(flPathName)
End Sub

Sub SaveRangeAsJPG(Rng As Range, FileName As String)
    Dim cht As Chart
    Dim bScreen As Boolean
    
    bScreen = Application.ScreenUpdating
    'If bScreen Then Application.ScreenUpdating = False     'Runtime error on With cht.Shapes(1) when this statement not commented out
    
    Rng.CopyPicture xlScreen, xlPicture
    Set cht = Workbooks.Add(xlChart).Charts(1)
    cht.ChartArea.Clear
    DoEvents
    cht.Paste
    With cht.Shapes(1)
        .LockAspectRatio = msoTrue
        .Width = cht.ChartArea.Width
        .Left = 0
        .Top = 0
    End With
    cht.Export FileName, "JPEG", False
    cht.Parent.Close False
    
    If bScreen Then Application.ScreenUpdating = True
End Sub

Sub SaveShapeAsJPG(Shp As Shape, FileName As String)
    Dim cht As Chart
    Dim bScreen As Boolean
    
    bScreen = Application.ScreenUpdating
    'If bScreen Then Application.ScreenUpdating = False     'Runtime error on With cht.Shapes(1) when this statement not commented out
    
    Shp.CopyPicture xlScreen, xlPicture
    Set cht = Workbooks.Add(xlChart).Charts(1)
    cht.ChartArea.Clear
    DoEvents
    cht.Paste
    With cht.Shapes(1)
        .Left = 0
        .Top = 0
        .Width = cht.ChartArea.Width
    End With
    cht.Export FileName, "JPEG", False
    cht.Parent.Close False
    
    If bScreen Then Application.ScreenUpdating = True
End Sub

Private Sub ExportImages()
    Dim Rng As Range
    Dim cht As Chart
    Dim Fn As String
    Dim shp1 As Shape, shp2 As Shape
    
    Set shp1 = ActiveSheet.Shapes("Apple")
    Set shp2 = ActiveSheet.Shapes("Coffee")
    Set Rng = ActiveSheet.Range("N1:P3")
    Set cht = ActiveSheet.ChartObjects(1).Chart
    
    Fn = ThisWorkbook.Path & Application.PathSeparator
    SaveRangeAsJPG Rng, Fn & "MyRange.jpg"
    SaveShapeAsJPG shp1, Fn & "Apple.jpg"
    SaveShapeAsJPG shp2, Fn & "Coffee.jpg"
    cht.Export Fn & "FoodChart.jpg"
End Sub

Here is the code I used for my test UserForm:
Code:
Private Sub ToggleButton1_Click()
    Dim ImageName As String, flPathName As String
    Image1.PictureAlignment = fmPictureAlignmentTopLeft
    Image1.PictureSizeMode = fmPictureSizeModeZoom
    ImageName = InputBox("What image do you want to display?")
    LoadPictureToImageControl ThisWorkbook.Path & Application.PathSeparator & ImageName, Image1
End Sub
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,123,504
Messages
5,602,060
Members
414,498
Latest member
jordanmiller7890

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
Top