Export Image from all files in VBA

[mehidy1437]

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.

What could be the reason?

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

 

[Dan_W]

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.

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:

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

 

[mehidy1437]

hi @Dan_W many thanks, it's worked, learned something new.

 

[Dan_W]

Glad to hear it, and thank you for the update. Hopefully this will help otherswho experience the same problem.