Extract Pictures From Multiple Sheet Overload (Occurring Duplicate)

[susanto]

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.

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/threads/exported-images-from-multiple-sheet-overload-occurring-duplicate.1138824/

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

sst.

[DocAElstein]

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
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
3146

So I can’t repeat the error….

Alan

[susanto]

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

[DocAElstein]

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"

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