代码在使用F8时有效，但在完全运行时无效

Question

首先，我不太擅长Excel宏。在浏览了多个论坛后，我设法想出了一个使用ExcelVBA在文件夹中裁剪图像的代码。

该代码在Excel中打开每个图像，粘贴到图表中，裁剪图像，调整大小以匹配高度&宽度，然后用编辑后的图像替换原始图像。

使用F8可以很好地执行宏，但当我完全运行宏时，图像不会被编辑后的图像替换，而是被空白图像替换。在深入研究了多个选项后，我得出的唯一结论是，该宏在Excel 2013中运行良好，但在office 365中运行不正常。

有人能帮我吗，如何解决这个问题，或者有更好的代码可以运行吗？

Option Explicit
Sub ImportData()
Dim XL As Object
Dim thisPath As String
Dim BooksPAth As String
BooksPAth = "C:Images" 

thisPath = ActivePresentation.path

Set XL = CreateObject("Excel.Application")

Run "Crop_vis", BooksPAth   
End Sub

Sub DeleteAllShapes()
Dim Shp As Shape
For Each Shp In ActiveSheet.Shapes
If Not (Shp.Type = msoOLEControlObject Or Shp.Type = msoFormControl) Then Shp.Delete
Next Shp
End Sub

Sub Crop_Vis(ByVal folderPath As String)
Dim Shp As Object, path As String, sht As Worksheet, s As Shape, TempChart As String
'Dim folderPath As String

Application.ScreenUpdating = True

If folderPath = "" Then Exit Sub
Set sht = Sheet1
sht.Activate
sht.Range("A10").Activate
path = Dir(folderPath & "*.jpg")

Do While path <> ""
DeleteAllShapes
Set Shp = sht.Pictures.Insert(folderPath & "" & path)
' Use picture's height and width.
Set s = sht.Shapes(sht.Shapes.Count)
s.PictureFormat.CropTop = 50
s.Width = 768
s.Height = 720

'Add a temporary chart in sheet1
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=sht.Name
Selection.Border.LineStyle = 0
TempChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)

With sht
'Change the dimensions of the chart to suit your need
With .Shapes(TempChart)
.Width = s.Width
.Height = s.Height
End With

'Copy the picture
s.Copy

'Paste the picture in the chart
With ActiveChart
.ChartArea.Select
.Paste
End With

'Finally export the chart
.ChartObjects(1).Chart.Export fileName:=folderPath & "" & path, FilterName:="jpg"
'Destroy the chart. You may want to delete it...
.Shapes(TempChart).Cut
End With
path = Dir
Loop
DeleteAllShapes
Application.DisplayAlerts = False
End Sub

Answer 1

之前

'Finally export the chart

插入这样的东西，以确保将图像粘贴到图表中已经完成：

Do
If ActiveChart.Shapes.Count > 0 Then
Exit Do
End If
Loop

Answer 2

问题出在粘贴上。当你告诉它将剪贴板(图像(粘贴到图表中时，有时它会忽略你。当你去导出图表时，你会得到一个空的图像。

这并不是说你必须等待它粘贴，因为它不会——它忽略了你。我不知道它为什么忽略你，也不知道它忽略你时为什么不出错——它只是在没有警告的情况下忽略你。也许Windows只是太忙了，无法粘贴。

基本上，你要做的是检查它是否粘贴，如果没有，请再次粘贴。。。。再一次。。。。直到它最终认为适合处理您的指令。

我在这个问题上调试、谷歌搜索、测试、出错，头撞在墙上一周，最后得到了这个：

Sub SavePictureFromExcel(shp As Shape, SavePath As String)
Dim Imagews As Worksheet
Dim tempChartObj As ChartObject
Dim ImageFullPath As String

Set Imagews = Sheets("Image Files")
Set tempChartObj = Imagews.ChartObjects.Add(0, 0, shp.Width, shp.Height)
shp.Copy
tempChartObj.Chart.ChartArea.Format.Line.Visible = msoFalse 'No Outline
tempChartObj.Chart.ChartArea.Format.Fill.Visible = msoFalse 'No Background

Do
DoEvents
tempChartObj.Chart.Paste
Loop While tempChartObj.Chart.Shapes.Count < 1

ImageFullPath = SavePath & "" & shp.Name & ".png"
tempChartObj.Chart.Export ImageFullPath, Filtername:="png"
tempChartObj.Delete
End Sub