Extract Pictures From Multiple Sheet Overload (Occurring Duplicate)

hello all..

Below code will generate a folder at the file's location, named by [filename]_Pictures with sub folders are named by sheet name inside, inside each subfolder is all pictures on the sheet.

Code:

---

Sub ExtractPictures()
Dim FSO As Object, sFolder As String, sTmpFolder As String, WB As Workbook, WS As Worksheet, i As Long
Set FSO = VBA.CreateObject("Scripting.FileSystemObject")
Set WB = ActiveWorkbook
sFolder = WB.Path & "\" & WB.Name & "_Pictures"
sTmpFolder = sFolder & "\TmpFolder"
If FSO.FolderExists(sFolder) Then
    FSO.DeleteFolder sFolder
End If
FSO.CreateFolder sFolder
FSO.CreateFolder sTmpFolder
Application.ScreenUpdating = False
For Each WS In WB.Worksheets
    If WS.Pictures.Count > 0 Then
        WS.Copy
        i = i + 1
        ActiveWorkbook.SaveAs Filename:=sTmpFolder & "\s" & i & ".htm", FileFormat:=xlHtml
        FSO.CreateFolder sFolder & "\" & WS.Name
        FSO.CopyFile sTmpFolder & "\s" & i & "_files\*.png", sFolder & "\" & WS.Name
        ActiveWorkbook.Close False
    End If
Next
Application.ScreenUpdating = True
FSO.DeleteFolder sTmpFolder
Shell "Explorer.exe /Open,""" & sFolder & """", 1
End Sub

---

this macro working not properly..after run macro code , picture automatic create 1 duplicate for each sheet..i don't want that..
for example..i have several sheets e.g. 5 sheets and every one sheet contains 3 picture so total pictures in 5 sheets = 15.
after run macro code above, total picture success exported is 30 that is overload, should be keep 15.

attachment sample file : https://app.box.com/s/od326p56jhau0qe0fx0kxuggg8j6gd5m

across post from https://www.mrexcel.com/board/thread...icate.1138824/

any body would help me, how to solve or modify that code

sst.

Hello susanto
Welcome to ExcelFox :)
Thanks for adding the cross post link.
Having read the conversation with you and yky at mrexcel.com , I think the biggest problem is communicating with you in English. But I will try :

---

_1) With your sample file, the macro errors in the second loop when trying to copy the .png files to the second Folder, BM 3311 R
I think you have seen that yourself, - on the second loop it errors at
FSO.CopyFile sTmpFolder & "\s" & i & "_files\*.png", sFolder & "" & WS.Name

This seems to arise because your second worksheet tab Name has an extra space character on the end, - its name is
"BM 3311 R "
ExtraSpaceAtEndOfWsName.JPG : https://imgur.com/n1hsLUv
Attachment 3145
Do you see that there are 10 characters there. Having 10 characters is not a problem. But the last character having a space seems to cause the problem in the coding.
If you change the file name to .._
"BM 3311 R"
( there are 9 characters there, no extra space at the end )
_.. then the macro does not error , and I can run the macro to completion

_2) Once the macro runs normally, I get correct results. So I am unable to get your problem.
In the oploded file are 3 pictures in each worksheet.
Finally , after running the macro I see two folders, each with 3 .png files in it :
2x3pngPics.JPG : https://imgur.com/rqwHgV3
Attachment 3146

So I can’t repeat the error….

Alan

hi Alan, thank for attention..

i have trying for the last my sample, and editing name of sheet (make simple without space) ..then running macro..
finally , the result is still wrong, duplicate pictures occurred again..
i don't know why????
i'm using Excel 2016..

this my attachment result (screen shoot compilation)

https://ibb.co/FH7Z1Bj

Hi susanto
I don’t understand why you still get the problem. I have not been able to see that problem with your sample file. I do not have much experience with embedded pictures, in fact this is the first time I have seen a macro like yours, so I am probably not the best person to help
I do notice that in the folders s1_files and s2_files there are always double pictures. For each picture there is a .png and a .gif
So this next suggestion of mine is really a long shot: Before the copy is made of the .png files, you could try deleting the .gif files, like this:

Kill sTmpFolder & "\s" & i & "_files\*.gif"

Code:

---

Sub ExtractPictures()
Dim FSO As Object, sFolder As String, sTmpFolder As String, WB As Workbook, WS As Worksheet, i As Long
Set FSO = VBA.CreateObject("Scripting.FileSystemObject")
Set WB = ActiveWorkbook
sFolder = WB.Path & "\" & WB.Name & "_Pictures"
sTmpFolder = sFolder & "\TmpFolder"
If FSO.FolderExists(sFolder) Then
    FSO.DeleteFolder sFolder
End If
FSO.CreateFolder sFolder
FSO.CreateFolder sTmpFolder
'Application.ScreenUpdating = False
For Each WS In WB.Worksheets
    If WS.Pictures.Count > 0 Then
        WS.Copy
        i = i + 1
        ActiveWorkbook.SaveAs Filename:=sTmpFolder & "\s" & i & ".htm", FileFormat:=xlHtml
        Kill sTmpFolder & "\s" & i & "_files\*.gif"
        FSO.CreateFolder sFolder & "\" & WS.Name
        FSO.CopyFile sTmpFolder & "\s" & i & "_files\*.png", sFolder & "\" & WS.Name '
        ActiveWorkbook.Close False
    End If
Next
Application.ScreenUpdating = True
FSO.DeleteFolder sTmpFolder
Shell "Explorer.exe /Open,""" & sFolder & """", 1
End Sub

---

I am afraid I have no other ideas.
I hope someone else can help here or at mrexcel
Good luck

Alan