VBA Extract All Images Into A Folder

muhammad susanto

Well-known Member
Joined
Jan 8, 2013
Messages
1,766
Office Version
  1. 2016
  2. 2010
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
 

Some videos you may like

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,977
Office Version
  1. 365
Platform
  1. Windows
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
 

muhammad susanto

Well-known Member
Joined
Jan 8, 2013
Messages
1,766
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
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:

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,977
Office Version
  1. 365
Platform
  1. Windows
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
 

muhammad susanto

Well-known Member
Joined
Jan 8, 2013
Messages
1,766
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows

ADVERTISEMENT

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"
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,977
Office Version
  1. 365
Platform
  1. Windows
like this
Rich (BB code):
For Each Ws In ActiveWorkbook.Worksheets
  For Each shp In Ws.Shapes
   other code
  Next Shp
Next Ws
 

muhammad susanto

Well-known Member
Joined
Jan 8, 2013
Messages
1,766
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
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
 

muhammad susanto

Well-known Member
Joined
Jan 8, 2013
Messages
1,766
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
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: 3

Watch MrExcel Video

Forum statistics

Threads
1,122,753
Messages
5,597,925
Members
414,191
Latest member
debbhatta

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
Top