VBA Extract All Images Into A Folder

muhammad susanto

Well-known Member
Joined
Jan 8, 2013
Messages
2,077
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
dear all.
i found below code to extract chart into a folder, i want someone would help me to modify this code to can extract all images into a folder e.g. folder c:/extract
my images in .jpg and .png format.
here this code:
VBA Code:
Sub ExportAllCharts()
    Dim objShell As Object
    Dim objWindowsFolder As Object
    Dim strWindowsFolder As String
    Dim objSheet As Excel.Worksheet
    Dim objChartObject As Excel.ChartObject
    Dim objChart As Excel.Chart

    'Select a Windows folder
    Set objShell = CreateObject("Shell.Application")
    Set objWindowsFolder = objShell.BrowseForFolder(0, "Select a Windows folder:", 0, "")

    If Not objWindowsFolder Is Nothing Then
       strWindowsFolder = objWindowsFolder.self.Path & "\"

       For i = ThisWorkbook.Worksheets.Count To 1 Step -1
           Set objSheet = ThisWorkbook.Worksheets(i)

           If objSheet.ChartObjects.Count > 0 Then
              For Each objChartObject In objSheet.ChartObjects
                  Set objChart = objChartObject.Chart
                  objChart.Export strWindowsFolder & objChart.Name & ".jpg"
              Next
          End If
       Next

       'Open the windows folder
       Shell "Explorer.exe" & " " & strWindowsFolder, vbNormalFocus
   End If
End Sub

any body home would help me, greatly appreciated..
.sst
 

Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney
This saves all images in active sheet to folder
The images are Named Pic1.. Pic2... Pic3 etc
Amend the code to suit your own requirements

VBA Code:
Sub SaveImages()
    Dim shp As Shape, ImageName As String, Temp As Object, tArea As Object, x As Long
    Application.ScreenUpdating = False
    For Each shp In ActiveSheet.Shapes
        If shp.Type = msoPicture Then
            x = x + 1
            ImageName = "Pic" & x
            shp.Select
            Application.Selection.CopyPicture
            Set Temp = ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height)
            Set tArea = Temp.Chart
            Temp.Activate
            With tArea
                .ChartArea.Select
                .Paste
                .Export ("C:\Test\jpg\New folder\" & ImageName & ".jpg")
            End With
            Temp.Delete
            DoEvents
        End If
    Next
End Sub
 
Upvote 0
thank you so much Yongle...
Working great!!! You're always coming..

hi Yongle, if you have time, how to make your code working in multiple sheets simultance
 
Last edited:
Upvote 0
Add an extra loop and replace every incidence of ActiveSheet with Ws

VBA Code:
Dim Ws as WorkSheet

For Each Ws In ActiveWorkbook.Worksheets

Next Ws
 
Upvote 0
Add an extra loop and replace every incidence of ActiveSheet with Ws

VBA Code:
Dim Ws as WorkSheet

For Each Ws In ActiveWorkbook.Worksheets

Next Ws
how to add above code
i have joint them like this :
VBA Code:
Sub SaveImages()
Dim Ws As Worksheet

For Each Ws In ActiveWorkbook.Worksheets

Next Ws
Dim shp As Shape, ImageName As String, Temp As Object, tArea As Object, x As Long
    Application.ScreenUpdating = False
    For Each shp In Ws.Shapes
        If shp.Type = msoPicture Then
            x = x + 1
            ImageName = "Pic" & x
            shp.Select
            Application.Selection.CopyPicture
            Set Temp = Ws.ChartObjects.Add(0, 0, shp.Width, shp.Height)
            Set tArea = Temp.Chart
            Temp.Activate
            With tArea
                .ChartArea.Select
                .Paste
                .Export ("C:\Test\jpg\New folder\" & ImageName & ".jpg")
            End With
            Temp.Delete
            DoEvents
        End If
    Next
End Sub
hi yongle thank you..
but not working show "can't execute code in break mode"
 
Upvote 0
like this
Rich (BB code):
For Each Ws In ActiveWorkbook.Worksheets
  For Each shp In Ws.Shapes
   other code
  Next Shp
Next Ws
 
Upvote 0
here complete code worked it..
VBA Code:
Sub SaveImages()
    Dim shp As Shape, ImageName As String, Temp As Object, tArea As Object, x As Long
    Application.ScreenUpdating = False
    For Each Ws In ActiveWorkbook.Worksheets
    For Each shp In Ws.Shapes
        If shp.Type = msoPicture Then
            x = x + 1
            ImageName = "Pic" & x
            shp.Select
            Application.Selection.CopyPicture
            Set Temp = Ws.ChartObjects.Add(0, 0, shp.Width, shp.Height)
            Set tArea = Temp.Chart
            Temp.Activate
            With tArea
                .ChartArea.Select
                .Paste
                .Export ("C:\Test\jpg\ok\" & ImageName & ".jpg")
            End With
            Temp.Delete
            DoEvents
        End If
    Next shp
    Next Ws
End Sub
 
Upvote 0
there is something erorr..
i have 4 pictures in 2 sheets not contains duplicate picture but after running macro, pic3 can't show picture
 

Attachments

  • blank.jpg
    blank.jpg
    26.9 KB · Views: 31
Upvote 0
Thanks Yongle that helpwd a lot just what i needed
 
Upvote 0

Forum statistics

Threads
1,213,521
Messages
6,114,104
Members
448,548
Latest member
harryls

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top