Chart.Export corrupting images randomly-CodePudding

I'm trying to extract multiple images from different excel files, but some images get corrupted during macro run. There's no pattern or something like, and if i run the macro multiple times with the same files, the images that get corrupted are different. I already tried to slow down the code using wait and sleep functions, but even using 5 seconds of delay (which is high for the amount of files that i want to extract) and the extracted images keep corrupting.

Here's the code:

Do While caminho <> False
If caminho = False Then Exit Sub

Workbooks.Open caminho

Set ficha = ActiveWorkbook

ActiveSheet.Select

i = 10000
j = 0

    
wsName = Sheets(1).Name
For Each shp In Sheets(1).Shapes
    If shp.Type = msoPicture Then
        shp.Select
        shp.Height = 300
        shp.Width = 300
        Charts.Add
        ActiveChart.Location xlLocationAsObject, wsName
        ActiveChart.ChartArea.Height = shp.Height
        ActiveChart.ChartArea.Width = shp.Width
        tempChart = Mid(ActiveChart.Name, Len(wsName)   2, 100)
        
        shp.Copy
        
        newHour = Hour(Now())
        newMinute = Minute(Now())
        newSecond = Second(Now())   1
        waitTime = TimeSerial(newHour, newMinute, newSecond)
        Application.Wait waitTime
        
        ActiveChart.Paste
        i = i   1
        'ActiveChart.Export Filename:=caminho_foto & ActiveWorkbook.Name & "-" & i & ".jpg", FilterName:="jpg"
        ActiveChart.Export Filename:=caminho_foto & shp.Name & "-" & i & ".jpg", FilterName:="jpg"
        ActiveSheet.Shapes(tempChart).Delete
    End If
Next

Any thoughts about how to solve this?

CodePudding user response：

The following code creates a temporary worksheet in which a chartobject is created in order to export each shape. Then it deletes the temporary worksheet when finished.

Note that the copy and paste operations are split into separate procedures, which should help with the timing.

First add the following procedure to your project...

Sub pasteShapeInChartAndExportToJPG(ByVal saveAsFilename As String, ByVal chrt As Chart)

        With chrt
            .Paste
            .Export Filename:=saveAsFilename, FilterName:="jpg"
            .Pictures(1).Delete
        End With

        DoEvents

End Sub

Then amend your code as follows...

Dim ws As Worksheet
Set ws = Sheets(1)

Dim tempWorksheet As Worksheet
Set tempWorksheet = Worksheets.Add

Dim tempChartObject As ChartObject
Set tempChartObject = tempWorksheet.ChartObjects.Add(Left:=0, Top:=0, Width:=-1, Height:=-1)

With tempChartObject
    .Activate 'probably not really needed
    .Chart.ChartArea.Format.Line.Visible = msoFalse
End With

wsName = ws.Name
For Each shp In ws.Shapes
    If shp.Type = msoPicture Then
        With shp
            .Height = 300
            .Width = 300
        End With
        With tempChartObject
            .Width = shp.Width
            .Height = shp.Height
        End With
        shp.Copy
        DoEvents
        pasteShapeInChartAndExportToJPG caminho_foto & shp.Name & "-" & i & ".jpg", tempChartObject.Chart
        i = i   1
    End If
Next

With Application
    .DisplayAlerts = False
    tempWorksheet.Delete
    .DisplayAlerts = True
End With