VBA saving images

[Hillsy7]

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!

 

[rpaulson]

try this,
set range and path as needed.

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]

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.

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:

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