Excel VBA 代码竞争条件未由 Wait、Sleep、DoEvents 等修复
Excel VBA Code Race Condition Not Fixed by Wait, Sleep, DoEvents, etc
已解决！解决方法见下方代码！
我有一个 Excel 文件，其中包含一系列文本旁边的多个形状对象。我写了一个脚本来识别每个形状的位置，识别文本延伸到右侧和下方的单元格数量，将其设置为一个范围，然后将其导入图表对象，以便我可以将其保存为 .jpg。
问题是在创建图表和粘贴字符串之间存在竞争条件。如果我单步执行脚本，它工作正常，但一旦我 运行 它除了空白图像我什么也得不到。
我试过了 Application.ScreenUpdating = True； Application.PrintCommunication = 正确；和 DoEvents
我也尝试过 Application.Wait，但即使等待 10 秒也无济于事，单步执行代码时，图表加载时间不到 2 秒。
最近也试了kernel32的sleep方法，好像也没用。同样，我让系统休眠的时间远远超过了我的步数。我还在 With 语句中的每一行之间添加了上述所有方法（显然不是作为解决方案，而是作为测试），但也没有用..
此时我完全不知所措。
如果我在 .Chart.Paste 处停止，然后 运行 脚本 (F5)，然后继续点击 运行，那么脚本会非常有效。我只是不希望用户必须坐在那里并点击 运行 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 的建议更新的，然后再次重新修改以添加所有以前关于如何在更改无效后修复 Race Condition 问题的建议。）
考虑使用 Application.OnTime，这是一个很好的功能。它允许某些代码在特定时间安排 运行，通常是在当前时间上增加几秒。
Excel VBA 是单线程的，因此没有真正的同步，但有一个消息泵来保持顺序。 Application.OnTime 的伟大之处在于它不会 运行 尽管被安排在当前代码图完成之前。
因为 Application.OnTime 使用消息泵，因为它是一个 FIFO 结构，所以可以交错执行代码。
我想这可能对这里有所帮助。
您可以安排一个 "hasItFinished" 过程来检查 shape/chart 对象是否存在，如果不存在则重新安排自己。
P.S。调试可能有点棘手，在您将安排的过程之外重构尽可能多的代码并分别对其进行单元测试。如果您沿着这条路走下去，请不要指望您通常使用 VBA 获得可爱的编辑、调试和继续流程。
尝试摆脱错误处理程序和标签，直接使用对象而不是搜索 workbook/worksheet 集合。此外，如果您遇到任何问题，使用有意义的变量名称和适当的缩进将有助于轻松遵循代码。
如果您的代码在单步执行时有效，这通常表明在 opened/closed 工作簿时使用 ActiveWorkbook 存在一些问题。将工作簿作为对象使用可以让我们克服这个问题，因为无论工作簿是否处于活动状态，我们始终使用该工作簿的相同 实例。
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
已解决！解决方法见下方代码！
我有一个 Excel 文件，其中包含一系列文本旁边的多个形状对象。我写了一个脚本来识别每个形状的位置，识别文本延伸到右侧和下方的单元格数量，将其设置为一个范围，然后将其导入图表对象，以便我可以将其保存为 .jpg。
问题是在创建图表和粘贴字符串之间存在竞争条件。如果我单步执行脚本，它工作正常，但一旦我 运行 它除了空白图像我什么也得不到。
我试过了 Application.ScreenUpdating = True； Application.PrintCommunication = 正确；和 DoEvents
我也尝试过 Application.Wait，但即使等待 10 秒也无济于事，单步执行代码时，图表加载时间不到 2 秒。
最近也试了kernel32的sleep方法，好像也没用。同样，我让系统休眠的时间远远超过了我的步数。我还在 With 语句中的每一行之间添加了上述所有方法（显然不是作为解决方案，而是作为测试），但也没有用..
此时我完全不知所措。
如果我在 .Chart.Paste 处停止，然后 运行 脚本 (F5)，然后继续点击 运行，那么脚本会非常有效。我只是不希望用户必须坐在那里并点击 运行 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 的建议更新的，然后再次重新修改以添加所有以前关于如何在更改无效后修复 Race Condition 问题的建议。）
考虑使用 Application.OnTime，这是一个很好的功能。它允许某些代码在特定时间安排 运行，通常是在当前时间上增加几秒。
Excel VBA 是单线程的，因此没有真正的同步，但有一个消息泵来保持顺序。 Application.OnTime 的伟大之处在于它不会 运行 尽管被安排在当前代码图完成之前。
因为 Application.OnTime 使用消息泵，因为它是一个 FIFO 结构，所以可以交错执行代码。
我想这可能对这里有所帮助。
您可以安排一个 "hasItFinished" 过程来检查 shape/chart 对象是否存在，如果不存在则重新安排自己。
P.S。调试可能有点棘手，在您将安排的过程之外重构尽可能多的代码并分别对其进行单元测试。如果您沿着这条路走下去，请不要指望您通常使用 VBA 获得可爱的编辑、调试和继续流程。
尝试摆脱错误处理程序和标签，直接使用对象而不是搜索 workbook/worksheet 集合。此外，如果您遇到任何问题，使用有意义的变量名称和适当的缩进将有助于轻松遵循代码。
如果您的代码在单步执行时有效，这通常表明在 opened/closed 工作簿时使用 ActiveWorkbook 存在一些问题。将工作簿作为对象使用可以让我们克服这个问题，因为无论工作簿是否处于活动状态，我们始终使用该工作簿的相同 实例。
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