Export Image from all files in VBA

mehidy1437

Active Member
Joined
Nov 15, 2019
Messages
289
Office Version
  1. 365
  2. 2016
  3. 2013
Platform
  1. Windows
  2. Mobile
  3. Web
Hi, I'm using the below code to export images from all files in a folder.
This works fine in Excel 2013, but in 2016 it's not exporting all the images in one shot, I have to run this macro a couple of times to do the job.

I'm getting the following error message.

Capture.JPG


What could be the reason?

VBA Code:
Option Explicit

Sub ExportImageFromAllFiles()
Dim folderPath As String
Dim filename As String
Dim wb As Workbook

folderPath = "E:\SHARENEW\SS21PRODUCTION\techincle sheet\"

If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"

filename = Dir(folderPath & "*.xls")
Do While filename <> ""
    Application.ScreenUpdating = False
    Set wb = Workbooks.Open(folderPath & filename)
              
    Dim MyChart As String, MyPicture As String
     Dim PicWidth As Long, PicHeight As Long

     Application.ScreenUpdating = False
     On Error GoTo Finish

     Dim mySheet As Variant
     mySheet = ActiveSheet.Name
     Dim mySheetIndex As Integer
     mySheetIndex = ActiveSheet.Index
     
     Dim nuMberdata As Integer
     nuMberdata = mySheetIndex + 1
     
     Dim myValue As Variant
              myValue = Range("c3").Value
        
        Dim Pic As Shape
        For Each Pic In ActiveSheet.Shapes
            If Pic.Type = msoPicture Then
            Pic.ScaleHeight 1#, True, msoScaleFromTopLeft
            Pic.ScaleWidth 1#, True, msoScaleFromTopLeft
            Pic.Select
            End If
        Next Pic
        
     MyPicture = Selection.Name
     With Selection
           PicHeight = .ShapeRange.Height
           PicWidth = .ShapeRange.Width
     End With

     Charts.Add

      ActiveChart.Location Where:=xlLocationAsObject, Name:=mySheet
     Selection.Border.LineStyle = 0
     MyChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(nuMberdata)

     With ActiveSheet
           With .Shapes(MyChart)
                 .Width = PicWidth
                 .Height = PicHeight
           End With

           .Shapes(MyPicture).Copy

           With ActiveChart
                 .ChartArea.Select
                 .Paste
           End With

           .ChartObjects(1).Chart.Export filename:=myValue & ".jpg", FilterName:="jpg"
           .Shapes(MyChart).Cut
     End With

     Application.ScreenUpdating = True

Finish:
wb.Close SaveChanges:=False
    filename = Dir
Loop
Application.ScreenUpdating = True
End Sub
 

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.

Dan_W

Well-known Member
Joined
Jul 11, 2018
Messages
715
Office Version
  1. 365
Platform
  1. Windows
Hi - I appreciate that a month+ has passed since you posted this, but have you found a solution to it yet? If you still haven't solved it, you might want to try slowing things down between Excel copying the images into memory and then proceeding to paste it, and same again before exporting it.

VBA Code:
Sub PAUSE(Period as single)
    Dim T as Single
    T = Timer
    Do
        DoEvents
    Loop Until T + Period < Timer
End Sub

You could call the PAUSE routine above in the following two places:

VBA Code:
 .Shapes(MyPicture).Copy
           PAUSE 1.5                    '   THIS WILL PAUSE THE EXECUTION OF THE CODE FOR 1.5 SECONDS
           With ActiveChart
                 .ChartArea.Select
                 .Paste
           End With
           PAUSE 2                     '   THIS WILL PAUSE THE EXECUTION OF THE CODE FOR 2SECONDS 
           .ChartObjects(1).Chart.Export filename:=myValue & ".jpg", FilterName:="jpg"

Sometimes it takes some playing around with the period of time to get it just right. Let me know if that works.
 
Solution

mehidy1437

Active Member
Joined
Nov 15, 2019
Messages
289
Office Version
  1. 365
  2. 2016
  3. 2013
Platform
  1. Windows
  2. Mobile
  3. Web
hi @Dan_W many thanks, it's worked, learned something new.
 

Dan_W

Well-known Member
Joined
Jul 11, 2018
Messages
715
Office Version
  1. 365
Platform
  1. Windows
Glad to hear it, and thank you for the update. Hopefully this will help otherswho experience the same problem.
 

Forum statistics

Threads
1,148,156
Messages
5,745,100
Members
423,923
Latest member
yuvaraj859

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