Extracting and Saving Images from Spreadsheet

Andrew Poulsom said:

Try:

Code:

Sub Test()
    Dim Folder As String
    Dim Pic As Picture
    Dim FileName As String
    Dim wb As Workbook
    Dim File As String
    Folder = ThisWorkbook.Path & Application.PathSeparator
    Application.ScreenUpdating = False
    For Each Pic In ActiveSheet.Pictures
        Set wb = Workbooks.Add
        With Pic
            FileName = .TopLeftCell.Offset(0, 1).Value
            .Copy
        End With
        ActiveSheet.Pictures.Paste
        With wb
            ActiveSheet.Name = FileName
            With .PublishObjects.Add(xlSourceSheet, Folder & FileName & ".htm" _
                , FileName, "", xlHtmlStatic, FileName, "")
                .Publish (True)
                .AutoRepublish = False
            End With
            .Close SaveChanges:=False
        End With
        File = Dir(Folder & FileName & "_files\" & FileName & "*.png")
        FileCopy Folder & FileName & "_files\" & File, Folder & File
        Kill Folder & FileName & ".htm"
        DoEvents
        Kill Folder & FileName & "_files\*.*"
        RmDir Folder & FileName & "_files"
    Next Pic
    Application.ScreenUpdating = True
End Sub

Click to expand...

Andrew Poulsom said:

To remove the _image001 change:

Code:

FileCopy Folder & FileName & "_files\" & File, Folder & File

to:

Code:

Name Folder & FileName & "_files\" & File As Folder & FileName & ".png"

To save as jpg would require a different approach as in:

http://www.mrexcel.com/forum/excel-questions/86030-saving-jpg-excel.html

But I have found issues with that in Excel 2010. You could use a graphics converter to convert from png to jpg.

Click to expand...

Andrew Poulsom said:

What error do you get?

Click to expand...