Excel VBA Code Race Condition Not Fixed by Wait, Sleep, DoEvents, etc

Question

SOLVED! See the code below for the solution!

I have an Excel file containing multiple shape objects next to a series of text. I wrote a script to identify the location of each shape, identify how many cells to the right and down the text extends to, sets that as a range and then imports that into a chart object so I can save it as a .jpg.

The trouble is that between the creation of the chart and the pasting of the string there exists a Race Condition. If I step through the script it works fine, but as soon as I run it I get nothing but blank images.

I've tried Application.ScreenUpdating = True; Application.PrintCommunication = True; and DoEvents

I've also tried Application.Wait, but even having it wait ten seconds doesn't do the trick, when stepping through the code the chart is loaded in less than 2 seconds.

Recently I tried the kernel32 sleep method as well, and that doesn't seem to work either. Again, the amount of time I let the system sleep far exceeded my stepping. I also added all of the above methods between each line within the With statement (obviously not as a solution, but as a test) and that didn't work either..

At this point I'm completely at a loss.

If I place a stop at .Chart.Paste and then run the script (F5), and just keep hitting Run then the script works wonderfully. I just don't want users to have to sit there and hit run 600 times.

There are obvious redundancies written in between the creation of the chart and pasting of the text. This is all in the attempt at getting the code to work properly when run, and once a solution is found most of that code will be removed.

    Option Explicit

    Public Function ChartCheck() As String

    ReCheckChart:
    DoEvents
    If ActiveWorkbook.ActiveSheet.ChartObjects.Count > 0 Then
    GoTo ContinuePaste:
    Else
    GoTo ReCheckChart:
    ContinuePaste:
    End If

    End Function


    Public Function GetFolder() As String

    Dim fldr As FileDialog
    Dim sItem As String

    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder to Save the Images In"
        .AllowMultiSelect = False
        If .Show  -1 Then GoTo NextCode:
        sItem = .SelectedItems(1)
    End With
    NextCode:
    GetFolder = sItem
    Set fldr = Nothing

    End Function


    Private Sub DNImageExtraction_Click()

    Dim fileName                As String
    Dim targetWorkbook          As Excel.Workbook
    Dim targetWorksheet         As Excel.Worksheet
    Dim saveLocation            As Variant
    Dim saveName                As String
    Dim targetShape             As Shape
    Dim workingRange            As Excel.Range
    Dim bottomRow               As Long
    Dim workingRangeWidth       As Double
    Dim workingRangeHeight      As Double
    Dim tempChart               As ChartObject

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    DNImageExtraction.AutoSize = False  'This is necessary to prevent the system I use from altering the font on the button
    DNImageExtraction.AutoSize = True
    DNImageExtraction.Height = 38.4
    DNImageExtraction.Left = 19.2
    DNImageExtraction.Width = 133.8

    fileName = Application.GetOpenFilename("Excel Files (*.xls*),*.xls*", , "Please select Excel file...")

    Set targetWorkbook = Workbooks.Open(fileName)
    Set targetWorksheet = targetWorkbook.ActiveSheet

    saveLocation = GetFolder

    For Each targetShape In targetWorksheet.Shapes

        Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Offset(1, 0)

        saveName = workingRange.Text

        If workingRange.Offset(0, 1).Value  "" Then
            If workingRange.Offset(1, 1).Value = "" Then
                Set workingRange = Nothing
                Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Resize(, 2)
            Else
                bottomRow = workingRange.Offset(0, 1).End(xlDown).Row
                Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Resize((bottomRow + 2 - workingRange.Row), 2)
            End If

            workingRangeWidth = workingRange.Width
            workingRangeHeight = workingRange.Height
        End If

        workingRange.CopyPicture Appearance:=xlPrinter, Format:=xlPicture

        Set tempChart = targetWorksheet.ChartObjects.Add(0, 0, workingRangeWidth, workingRangeHeight)


    Application.ScreenUpdating = True
    Application.PrintCommunication = True
    DoEvents
    Call ChartCheck

            tempChart.Chart.Paste
    Application.ScreenUpdating = False
            tempChart.Chart.Export fileName:=saveLocation & "\DN " & saveName & ".jpg", Filtername:="JPG"
            tempChart.Delete
        Set tempChart = Nothing

    Next

    Application.Workbooks(targetWorkbook.Name).Close savechanges:=False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Any assistance in either a solution to the Race Condition, or re organizing the script to avoid the Race Condition altogether would be greatly appreciated.

(Code above was updated per suggestions made by Macro Man, and then re-modified once again to add in all previous suggestions on how to fix Race Condition issues after the changes were not effective.)

Answer 1

Consider using Application.OnTime which is good feature. It allows the scheduling of some code to be run at a certain time, most often one adds a few seconds to the current time.

Excel VBA is single-threaded and so there is no real synchronization but there is a message pump to keep order. The great thing about Application.OnTime is that it will not run despite being scheduled until the current graph of code has completed.

Because Application.OnTime uses the message pump as that is a FIFO structure it is possible to interleave the execution of code.

I think this might help here.

You can schedule a "hasItFinished" procedure which checks the existence of the shape/chart objects and if not re-schedules itself.

P.S. Can be a little tricky to debug, refactor as much code as possible outside of the procedure that you will schedule and unit test them separately. Please don't expect the lovely Edit,Debug and Continue flow that you normally get with VBA if you go down this path.

Answer 2

Try getting rid of the error handlers and labels, and working with objects directly instead of searching through workbook/worksheet collections. Also using meaningful variable names and proper indentation will help follow the code easily should you have any issues.

If your code works when stepping through, that usually suggests there is some issue with the use of ActiveWorkbook when workbooks are being opened/closed. Working with workbooks as objects allows us to overcome that problem because no matter if the workbook is active or not, we are always using the same instance of that workbook.

Private Sub DNImageExtraction_Click()

    Dim fileName                As String
    Dim targetWorkbook          As Excel.Workbook
    Dim targetWorksheet         As Excel.Worksheet
    Dim saveLocation            As Variant
    Dim saveName                As String
    Dim targetShape             As Shape
    Dim workingRange            As Excel.Range
    Dim bottomRow               As Long
    Dim workingRangeWidth       As Double
    Dim workingRangeHeight      As Double
    Dim tempChart               As ChartObject

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    fileName = Application.GetOpenFilename("Excel Files (*.xls*),*.xls*", , "Please select Excel file...")

    Set targetWorkbook = Workbooks.Open(fileName)
    Set targetWorksheet = targetWorkbook.ActiveSheet

    saveLocation = GetFolder

    For Each targetShape In targetWorksheet.Shapes

        Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Offset(1, 0)

        saveName = workingRange.Text

        If workingRange.Offset(0, 1).value <> "" Then
            If workingRange.Offset(1, 1).value = "" Then
                Set workingRange = Nothing
                Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Resize(, 2)
            Else
                bottomRow = workingRange.Offset(0, 1).End(xlDown).Row
                Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Resize((bottomRow + 2 - workingRange.Row), 2)
            End If

            workingRangeWidth = workingRange.Width
            workingRangeHeight = workingRange.Height
        End If

        workingRange.CopyPicture Appearance:=xlPrinter, Format:=xlPicture

        Set tempChart = targetWorksheet.ChartObjects.Add(0, 0, workingRangeWidth, workingRangeHeight)

        With tempChart
            .Chart.Paste
            .Chart.Export FileName:=saveLocation & "\DN " & saveName & ".jpg", Filtername:="JPG"
            .Delete
        End With

        Set tmpChart = Nothing

        DoEvents

    Next

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub