Extracting and Saving Images from Spreadsheet

[RockyRobin]

Hi

I have a spreadsheet that contains product images in cells in column A. In the matching cell in column B there are product codes. I would like to be able to "batch/bulk" save these images and label them by the corresponding product.

Is this possible. Or is there a different way around this issue.

Thanks in advance.

 

[Andrew Poulsom]

Which line of code is running when you get that prompt?

 

[RockyRobin]

Which line of code is running when you get that prompt?

Hi.

Its a line 58

Regards

RR

 

[Andrew Poulsom]

There aren't 58 lines in the code I posted. Which line is highlighted when you click Debug?

 

[RockyRobin]

There aren't 58 lines in the code I posted. Which line is highlighted when you click Debug?

Apologies Andrew, its one of those days. Its was a ~Run Time Error "58" The line of code highlighted after the debug is:-

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

 

[Andrew Poulsom]

Maybe try:

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
        If Dir(Folder & FileName & ".png") <> "" Then
            Kill Folder & FileName & ".png"
        End If
        File = Dir(Folder & FileName & "_files\" & FileName & "*.png")
        Name Folder & FileName & "_files\" & File As Folder & FileName & ".png"
        Kill Folder & FileName & ".htm"
        DoEvents
        Kill Folder & FileName & "_files\*.*"
        RmDir Folder & FileName & "_files"
    Next Pic
    Application.ScreenUpdating = True
End Sub

 

[RockyRobin]

Maybe try:

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
        If Dir(Folder & FileName & ".png") <> "" Then
            Kill Folder & FileName & ".png"
        End If
        File = Dir(Folder & FileName & "_files\" & FileName & "*.png")
        Name Folder & FileName & "_files\" & File As Folder & FileName & ".png"
        Kill Folder & FileName & ".htm"
        DoEvents
        Kill Folder & FileName & "_files\*.*"
        RmDir Folder & FileName & "_files"
    Next Pic
    Application.ScreenUpdating = True
End Sub

That did the trick perfectly. thanks!!! Great Support as always.

 

[RockyRobin]

That did the trick perfectly. thanks!!! Great Support as always.

Hi

When I apply a data filter to the spreadsheet, the filter doesnt appear to be adjusting all the images that have been attached. Is there a way to fix this?

 

[Andrew Poulsom]

Are the pictures set to 'Move and size with cells'?

 

[RockyRobin]

Are the pictures set to 'Move and size with cells'?

They weren't no. They are now and it works perfectly. Thanks as always.

 

[RockyRobin]

Hi

I've encountered another error when trying to run this macro to extract images from a spreadsheet.
As the macro is running during the process it has stopped and I get the runtime error "1004":
"Methid "Publish" of object "PublishObject" failed.
When I Debug it highlights the text below.

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
If Dir(Folder & FileName & ".png") <> "" Then
Kill Folder & FileName & ".png"
End If
File = Dir(Folder & FileName & "_files\" & FileName & "*.png")
Name Folder & FileName & "_files\" & File As Folder & FileName & ".png"
Kill Folder & FileName & ".htm"
DoEvents
Kill Folder & FileName & "_files\*.*"
RmDir Folder & FileName & "_files"
Next Pic
Application.ScreenUpdating = True
End Sub

Alternatively if I click "End" it opens an extra excel window and displays an image from the original sheet. With the workbook labelled as the product code.

Any ideas on the reason why this is happening or a possible solution.

Thanks