我有一个Excel文件，其中包含一系列文本旁边的多个形状对象。我编写了一个脚本来识别每个形状的位置，识别文本右侧和下方延伸的单元格数量，将其设置为范围，然后将其导入图表对象，以便将其保存为.jpg。 / p>
问题在于，在创建图表和粘贴字符串之间存在竞争条件。如果我单步执行脚本它可以正常工作，但是一旦我运行它，我只会得到空白图像。
我尝试过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提出的建议进行了更新，然后再次重新修改，以添加以前有关如何在更改无效后修复竞争条件问题的建议。）
答案 0 :(得分：6)
考虑使用Application.OnTime这是一个很好的功能。它允许某些代码的调度在特定时间运行，最常见的是在当前时间增加几秒。
Excel VBA是单线程的，因此没有真正的同步，但有一个消息泵来保持秩序。关于Application.OnTime的好处是，尽管在目前的代码图表完成之前进行了调度，它仍无法运行。
因为Application.OnTime使用消息泵，因为它是FIFO结构，所以可以交错执行代码。
我认为这可能对此有所帮助。
您可以安排＆＃34; hasItFinished＆＃34;检查形状/图表对象是否存在的程序，如果没有重新计划自己。
P.S。调试可能有点棘手，在您将要安排的过程之外重构尽可能多的代码并单独对它们进行单元测试。如果沿着这条路走下去，请不要期待VBA通常可以获得的可爱的编辑，调试和继续流程。
答案 1 :(得分：2)
尝试删除错误处理程序和标签，直接使用对象而不是搜索工作簿/工作表集合。如果您有任何问题，还可以使用有意义的变量名称和正确的缩进来帮助您轻松地遵循代码。
如果您的代码在单步执行时有效，那通常表明在打开/关闭工作簿时使用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