Excel VBA代码竞争条件无法通过Wait,Sleep,DoEvents等修复

Question

解决了!请参阅以下代码了解解决方案!

我有一个Excel文件,其中包含一系列文本旁边的多个形状对象.我编写了一个脚本来识别每个形状的位置,识别文本右侧和下方延伸的单元格数量,将其设置为范围,然后将其导入图表对象,以便将其保存为.jpg.

问题是在创建图表和粘贴字符串之间存在竞争条件.如果我单步执行脚本它工作正常,但是一旦我运行它我只得到空白图像.

我试过Application.ScreenUpdating = True; Application.PrintCommunication = True; 和DoEvents

我也尝试过Application.Wait,但即使让它等待十秒也不行,当踩过代码时,图表加载的时间不到2秒.

最近我也尝试了kernel32 sleep方法,但这似乎也没有用.同样,我让系统睡眠的时间远远超过了我的踩踏.我还在With语句中的每一行之间添加了所有上述方法(显然不是作为解决方案,而是作为测试),这也不起作用..

在这一点上,我完全不知所措.

如果我在.Chart.Paste停止然后运行脚本(F5),然后继续点击Run,那么脚本运行得非常好.我只是不希望用户必须坐在那里并运行600次.

在创建图表和粘贴文本之间存在明显的冗余.这一切都是为了让代码在运行时正常工作,一旦找到解决方案,大部分代码都将被删除.

    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

任何有关竞争条件的解决方案的帮助,或重新组织脚本以完全避免竞争条件将不胜感激.

(上面的代码根据Macro Man提出的建议进行了更新,然后再次重新修改,以添加以前有关如何在更改无效后修复竞争条件问题的建议.)

Answer 1

考虑使用 Application.OnTime哪个是好的功能.它允许某些代码的调度在特定时间运行,最常见的是在当前时间增加几秒.

Excel VBA是单线程的,因此没有真正的同步,但有一个消息泵来保持顺序.最棒的Application.OnTime是,尽管在当前的代码图表完成之前进行了调度,它仍无法运行.

因为Application.OnTime使用消息泵作为FIFO结构,所以可以交错执行代码.

我认为这可能对此有所帮助.

您可以安排"hasItFinished"过程,该过程检查形状/图表对象的存在,如果不重新安排自己.

PS调试可能有点棘手,在您将安排的程序之外重构尽可能多的代码并单独对它们进行单元测试.如果沿着这条路走下去,请不要指望通常用VBA获得的可爱的编辑,调试和继续流程.