Question

作为PowerPoint报表自动化的一部分，我将从Excel启用宏的工作簿中复制表到PowerPoint演示文稿，并从Excel运行VBA代码。这是一个更大的项目的一部分，但是代码的关键部分如下：

Sub test()
    Dim mainWb As Workbook
    Dim graphsWs As Worksheet
    Dim pptApp As PowerPoint.Application
    Dim pptTemp As PowerPoint.Presentation
    Dim pptSlide As PowerPoint.slide
    Dim shp As PowerPoint.Shape

    Set mainWb = ThisWorkbook
    Set graphsWs = mainWb.Sheets(1)
    Set pptApp = New PowerPoint.Application
    Set pptTemp = pptApp.Presentations.Add
    Set pptSlide = pptTemp.Slides.AddSlide(1, pptTemp.SlideMaster.CustomLayouts(1))
    With pptSlide
        .Name = "Destination"
        graphsWs.Range("A2:B4").Copy
        .Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
        DoEvents
        Debug.Print (.Shapes(.Shapes.Count).Name) ' Should print "Table X", but instead prints "Subtitle"
    End With
End Sub

问题： Debug.Print行的名称为“ Subtitle 2”，在这里我希望它的名称为“ Table 3”，因为该表是最近复制到工作表中的东西。此外，在执行代码后，请尝试在PowerPoint VBA中在?ActivePresentation.Slides(1).Shapes(ActivePresentation.Slides(1).Shapes.Count).Name即时窗口中编写代码，如预期的那样，获得表3。

假设：：脚本的运行似乎没有不等待粘贴代码的行（.Application.CommandBars.ExecuteMso ("PasteSourceFormatting")完成，然后执行下一行。如果是这样，它将给出我所看到的结果（据我所知）。

可能的解决方法：如果我的假设正确，那么使用Application.Wait语句可能会起作用，但是，我不喜欢仅花费几毫秒或等待几秒钟，因为不同计算机上的不同用户将使用此脚本。

问题：是否有更好的方法告诉应用程序在忙时等待？（在PowerShell Web爬网脚本中，我以前使用过类似的命令：while($ie.Busy){Sleep 1}，但在Excel VBA中似乎找不到类似的东西。

PS ：感谢蒂姆指出与this相关的问题。我已经添加了DoEvents，但它似乎仍然无法解决问题...

非常感谢您的帮助！

Answer 1

您可以尝试在粘贴之前获取.Shapes.Count的值，然后进入DoEvents循环，直到该值增加一。将时间限制也放入循环中可能是一个好主意。

Dim i As Long, t

With pptSlide
    .Name = "Destination"
    i = .Shapes.Count
    graphsWs.Range("A2:B4").Copy
    .Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
    t = Timer
    Do While .Shapes.Count = i 
        DoEvents
        If Timer - t > 2 Then Exit Do '<< exit after a couple of seconds
    Loop
    Debug.Print (.Shapes(.Shapes.Count).Name) 
End With

Answer 2

根据@TimWilliams的建议，以下代码有效：

Sub test()
    Dim mainWb As Workbook
    Dim graphsWs As Worksheet
    Dim pptApp As PowerPoint.Application
    Dim pptTemp As PowerPoint.Presentation
    Dim pptSlide As PowerPoint.slide
    Dim shp As PowerPoint.Shape
    Dim i As Long, shapesCount As Long
    i = 0 ' Counter for DoEvents Loop
    shapesCount = 0
    Set mainWb = ThisWorkbook
    Set graphsWs = mainWb.Sheets(1)
    Set pptApp = New PowerPoint.Application
    Set pptTemp = pptApp.Presentations.Add
    Set pptSlide = pptTemp.Slides.AddSlide(1, pptTemp.SlideMaster.CustomLayouts(1))
    With pptSlide
        .Name = "Destination"
        graphsWs.Range("A2:B4").Copy
        .Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
        shapesCount = .Shapes.Count
        Do While shapesCount = .Shapes.Count
            DoEvents
            i = i + 1
            If i > 10000 Then Exit Do
        Loop
        Debug.Print (.Shapes(.Shapes.Count).Name)
        Debug.Print (i)
    End With
End Sub

建议是： 您可以尝试在粘贴之前获取.Shapes.Count的值，然后进入DoEvents循环，直到该值增加一。将时间限制也放在循环上可能是一个好主意

将表格从Excel复制到PowerPoint时找不到形状-VBA在完成粘贴功能之前会运行到下一行

2 个答案: