Sub test()
'pics in Sheet2 "A"; file name in sheet2 "B"
Dim MyChart As Chart
Dim sh As Shape
On Error GoTo below
Application.ScreenUpdating = False
'add temp chart
Charts.Add.Location Where:=xlLocationAsObject, Name:="Sheet2"
Sheets("Sheet2").ChartObjects(Sheets("Sheet2").ChartObjects.Count).Name = "MYChart"
With Sheets("Sheet2")
For Each sh In .Shapes
If sh.Type = msoPicture Then
'make jpg files. Pics in any column with file name to right column
Call CreateJPG(sh.Name, CStr(.Range(sh.TopLeftCell.Address).Offset(, 1)), sh)
End If
Next sh
End With
'remove temp chart
Sheets("Sheet2").ChartObjects("MYChart").Delete
below:
Application.ScreenUpdating = True
If Err.Number <> 0 Then
MsgBox "Error"
End If
End Sub
Sub CreateJPG(PicName As String, FileNm As String, Shp As Shape)
'make image files
'picname is XL picture name; FileNm is name of file; Shp is pic in cell
Dim xRgPic As Shape
ThisWorkbook.Worksheets("sheet2").Activate
Set xRgPic = ThisWorkbook.Worksheets("sheet2").Shapes(PicName)
xRgPic.CopyPicture
'delete prev pic
With Sheets("Sheet2").ChartObjects("MYChart").Chart
Do While .Shapes.Count > 0
.Shapes(1).Delete
Loop
'size chart to Rng cell
.Parent.Height = Shp.Height
.Parent.Width = Shp.Width
.Parent.Top = Shp.Top
.Parent.Left = Shp.Left
End With
'make file in wb path
With Sheets("Sheet2").ChartObjects("MYChart")
.Activate
.Chart.Paste
.Chart.Export ThisWorkbook.Path & "\" & ValidFilePath(FileNm) & ".jpg", "JPG"
End With
End Sub
Public Function ValidFilePath(Arg As String) As String
Dim RegEx As Object
Set RegEx = CreateObject("VBScript.RegExp")
With RegEx
.Pattern = "[\\/:\*\?""<>\|]"
.Global = True
ValidFilePath = .Replace(Arg, "_")
End With
Set RegEx = Nothing
End Function
