I've found something in my drawer:
Sub ExportAllPictures()
Dim MyChart As Chart
Dim n As Long, shCount As Long
Dim Sht As Worksheet
Dim pictureNumber As Integer
Application.ScreenUpdating = False
pictureNumber = 1
For Each Sht In ActiveWorkbook.Sheets
shCount = Sht.Shapes.Count
If Not shCount > 0 Then Exit Sub
For n = 1 To shCount
'If InStr(Sht.Shapes(n).Name, "Picture") > 0 Then
'create chart as a canvas for saving this picture
Set MyChart = Charts.Add
MyChart.Name = "TemporaryPictureChart"
'move chart to the sheet where the picture is
Set MyChart = MyChart.Location(Where:=xlLocationAsObject, Name:=Sht.Name)
'resize chart to picture size
MyChart.ChartArea.Width = Sht.Shapes(n).Width
MyChart.ChartArea.Height = Sht.Shapes(n).Height
MyChart.Parent.Border.LineStyle = 0 'remove shape container border
'copy picture
Sht.Shapes(n).Copy
'paste picture into chart
MyChart.ChartArea.Select
MyChart.Paste
'save chart as jpg
MyChart.Export Filename:="z:\" & pictureNumber & ".jpg", FilterName:="jpg" ' that's the place where all picture will be saved
pictureNumber = pictureNumber + 1
'delete chart
Sht.Cells(1, 1).Activate
Sht.ChartObjects(Sht.ChartObjects.Count).Delete
'End If
Next
Next Sht
Application.ScreenUpdating = True
End Sub
should works.
Bookmarks