Exported Images From Multiple sheet Overload (Occurring Duplicate)

[muhammad 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

across post from Export Images From Multiple Sheet Into a Folder [SOLVED]

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.

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

.sst

 

[yky]

I just tested it again. I have one picture in sheet 1, 2, and 6. After running the code, I got one picture in folder sheet1, one in sheet2, and one in sheet6. There is no duplicate.

 

[yky]

By the way, I checked the file size of one of the saved picture, it has increased from the original 17.3K to 219K. Yet, the picture is blur, not as sharp as the original. This method of saving pictures doesn't seem to be ideal.

 

[yky]

Try this. It should give you better quality pictures.

Sub Export_Pictures_New_short()

    'This script exports all the pictures in each sheet in the Activebook
    'to individual folder
    '
    Dim FSO As Object, sFolder As String, sTmpFolder As String, WS As Worksheet, i As Long
    Dim picturename As String, filepath As String
     Dim WB As Workbook
    Dim init_PicWidth As Variant, init_PicHeight As Variant 'initial picture size, for restoring pic to its original size
    Dim shp As Shape
    Dim tempChart As Chart
    Dim chartName As String
    Dim sheetname As String
    Dim sh As Worksheet
    Dim PicCount As Integer
    Const factor = 1.65963687

   
    Set WB = ActiveWorkbook

    Set FSO = VBA.CreateObject("Scripting.FileSystemObject")
    
    filepath = WB.Path & "\" & WB.Name & "_Pictures"
    If Len(Dir(WB.Path & "\" & WB.Name & "_Pictures", vbDirectory)) = 0 Then

        FSO.CreateFolder WB.Path & "\" & WB.Name & "_Pictures"

    End If


    Workbooks(WB.Name).Activate

    For Each sh In WB.Sheets
        filepath = WB.Path & "\" & WB.Name & "_Pictures" & "\" & sh.Name
    
        If Len(Dir(filepath, vbDirectory)) = 0 Then

            FSO.CreateFolder filepath

        End If
        i = 0

        'sheetname = wb.Sheets(1).Name
        sheetname = sh.Name
        PicCount = sh.Shapes.Count

        Set tempChart = Charts.Add

        'insert the chart to the previously active sheet
        '(once a chart is added, it becomes the activesheet.).

        tempChart.Location xlLocationAsObject, Name:=sheetname

        'when a chart is added to a sheet, its name changes to reflectf
        'the chart number of the sheet and is preceeded by the name of
        'the sheet. That's why the sheetname is removed from the chart
        'name
        chartName = Mid(ActiveChart.Name, Len(sheetname) + 2)

        'For Each shp In ActiveSheet.Shapes

        For i = 1 To PicCount

            Set shp = ActiveSheet.Shapes(i)


            picturename = i

            'restore the photo to its original size
            'shp.ScaleHeight 1, msoTrue
            'only needs to do one, either height or width
            'the other is automatically done

            init_PicWidth = shp.Width
            init_PicHeight = shp.Height

            ''don't use. this will cause distortion

            'shp.ScaleHeight 1.7, True, msoScaleFromTopLeft
            'shp.ScaleWidth 10, True, msoScaleFromTopLeft


            'if picture doesn't exist then export it
            'because the newly added chart is also a member of shapes, it will be exported.
            'thus, only shape that contains no chart will be exported.

            'need to use two ifs to separate Dir from the other two
            'otherwise, when Dir causes an error, the script won't run

            If shp.Name <> "Chart 1" And shp.HasChart = False Then
                If Dir(filepath & picturename & ".jpg") = "" Then

                    shp.Height = shp.Height * factor
                    'shp.Width = shp.Width * factor

                    With ActiveSheet.Shapes(chartName)
                        'Change the dimensions of the chart to suit your need
                        .Width = shp.Width
                        .Height = shp.Height
                    End With

                    'Copy the picture
                    shp.Copy

                    ActiveChart.Paste

                    'Finally export the chart
                    ActiveChart.Export Filename:=filepath & "\" & i & ".jpg", FilterName:="jpg"

                    shp.Width = init_PicWidth
                    shp.Height = init_PicHeight

                    ActiveChart.Shapes(1).Delete


                End If

            End If

        Next

    'delete chart
    ActiveChart.ChartArea.Clear

    Next sh

    'tempChart.Delete


    Application.DisplayAlerts = False
    'ActiveWorkbook.Close savechanges:=False

End Sub

 

[muhammad susanto]

hi yky..
wow.....this worked perfectly..[SOLVED].
THANK YOU SO MUCH!!!!!!

 

[yky]

The last three lines of code need to be deleted.

'tempChart.Delete
Application.DisplayAlerts = False
'ActiveWorkbook.Close savechanges:=False

 

[mr67]

The last three lines of code need to be deleted.

'tempChart.Delete
Application.DisplayAlerts = False
'ActiveWorkbook.Close savechanges:=False

Hello my friend
Can you help me solve this problem?
I have two sheets, inside the first sheet there are two columns, the first column has the serial number and the second column has the content of the photo.
My goal is that in the second sheet, when I enter the serial number in the first column, the relevant image of the first sheet is called in the second column.

Attachments​

• 
  sheet2.png
  38.7 KB · Views: 3
• 
  
• 
  
• 
  
• 
  
• 
  sheet1.png
  73.2 KB · Views: 3
  
  
  

  reference -.xlsx

  Refrence Sheet New ردیف,part num,name (EN),name(FA),type,نام کالا,package,rang / part name,diamension,volt / watt,real pic,source,P./N.,buy,diamension pic,PACKING,paking pic,datasheet,website,expalain 2,11030128,Resistor,مقاومت,SMD,SMDمقاومت,1206,0Ω,L:3.2mm±0.2mm W:1.6mm±0.2mm H:0.55±0.15mm C:0....

  docs.google.com

 

[Fluff]

Duplicate to: Vlookup picture

In future, please do not post the same question multiple times. Per Forum Rules (#12), posts of a duplicate nature will be locked or deleted.

In relation to your question here, I have closed this thread so please continue in the linked thread.