CODEWITHSUNDEEP
vbaexcelpowerpoint
Prebsus
Prebsus

Reputation: 695

Unable to find shape when copying table from Excel to PowerPoint - VBA runs to next line before completing the pasting function

As part of a PowerPoint report automation, I'm copying a table from an Excel Macro-Enabled workbook to a PowerPoint presentation, running the VBA code from Excel. This is part of a bigger project, but the key parts of the code is as follows:

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

Problem: The Debug.Print line gives be "Subtitle 2", where I expected it to give me "Table 3", as the table is the thing that was most recently copied into the sheet. In addition, when I, after the code has executed, try in PowerPoint VBA to write in the immediate window ?ActivePresentation.Slides(1).Shapes(ActivePresentation.Slides(1).Shapes.Count).Name I get the Table 3 as I would expect.

Hypothesis: It seems that the running of the script does not wait for the line that pastes the code (.Application.CommandBars.ExecuteMso ("PasteSourceFormatting") to complete before executing the next line. If this was true, it would give the result I see (as far as I can understand).

Potential fix: If my hypothesis is correct, then Using a Application.Wait-statement could potentially work, however, I don't like the idea of just throwing in a few milliseconds or seconds wait, as different users on different computers will be using this script.

Question: Is there a better way to tell the application to wait while it is busy? (In a PowerShell web-scrape script I've previously used something like: while($ie.Busy){Sleep 1}, but I can't seem to find anything similar in Excel VBA.

PS: Thanks to Tim for pointing out this related question. I've added my DoEvents, but it still doesn't seem to fix the problem...

Any help here is much appreciated!

Upvotes: 0

Views: 393

Answers (2)

Prebsus
Prebsus

Reputation: 695

Following suggestion from @TimWilliams, the following code works:

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

The suggestion was: You could try getting the value of .Shapes.Count before the paste, then go into a DoEvents loop until the value has increased by one. Probably a good idea to put a time limit on the loop too

Upvotes: 0

Tim Williams
Tim Williams

Reputation: 166146

You could try getting the value of .Shapes.Count before the paste, then go into a DoEvents loop until the value has increased by one. Probably a good idea to put a time limit on the loop too.

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

Upvotes: 1

Related Questions