how to delay Past until complete merge shapes

[Dossfm0q]

Greetings
1-How delay paste until merge shapes function in red color
2- it is work well if remove pptApp.Quit ' close Power Point
3- to declare Sld as object to avoid select Microsoft Power point Reference

Sub CombineShapes()
    
Dim WB As Workbook
Dim WS As Worksheet
Dim Shp As Shape, Rctangl As Shape, Ovl As Shape
Dim Names(1 To 2) As Variant
Set WB = ThisWorkbook 'Set WB = Workbooks("WorkbookName")
Set WS = WB.ActiveSheet 'Set WS = WB.WorkSheets("WorkSheetName")


With WS
    For Each Shp In .Shapes
        Shp.Delete
    Next
    
   ' Add Shape
    Set Rctngl = WS.Shapes.AddShape(msoShapeRectangle, 100, 100, 125, 200)
        With Rctngl
            .Name = "MyRectangle"
            Names(1) = .Name
        End With
    
   ' Add Hole
    Set Ovl = WS.Shapes.AddShape(msoShapeOval, Rctngl.Left + (Rctngl.Width * 0.5) - 15, Rctngl.Top + 15, 30, 30)
        With Ovl
            .Name = "Oval"
            Names(2) = .Name


        End With
         
    With .Shapes.Range(Names)
    
    .Select
    End With
    
    Selection.Cut
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 Merge_Shapes ''''' go to Power Point to merge shapes
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
[COLOR=#ff0000]
[/COLOR]
[SIZE=2][B][COLOR=#ff0000].Paste ''' how to delay Paste untill Merge_Shapes complete and cut then Paste[/COLOR][/B][/SIZE]
End With 'WS


End Sub
Public Function Merge_Shapes()


Dim pptApp As Object
Dim pptPres As Object
[B][COLOR=#ff0000]Dim Sld As slide[/COLOR][/B]
Dim Visibility As Boolean
'Visibility = msoFalse ' To   pptApp Hide
Visibility = msoTrue ' to appear pptApp
    
    On Error Resume Next
        Set pptApp = Nothing
        Set pptApp = CreateObject("Powerpoint.Application")
        
        pptApp.Visible = Visibility ' To pptApp Hide
        If Visibility = msoTrue Then pptApp.Activate ' To pptApp Hide
        
        Set pptPres = pptApp.Presentations.Add(WithWindow:=Visibility) ' To keep pptApp Hide
        Set pptLayout = pptPres.Designs(1).SlideMaster.CustomLayouts(7)
        Set Sld = pptPres.Slides.AddSlide(1, pptLayout)
        pptApp.Visible = msoFalse
    
    On Error GoTo 0
    
        With Sld
                .Shapes.Paste '.Select 'for PowerPoint dot Shapes dot Paste
        
                .Shapes.Range(Array("MyRectangle", "Oval")).Select  '.MergeShapes (msoMergeCombine)
                .Shapes.Range(Array("MyRectangle", "Oval")).MergeShapes (msoMergeCombine)
        
                .Shapes(.Shapes.Count).Cut ' cut to be pasteed on Excel
        End With


[COLOR=#ff0000] pptApp.Quit ' close Power Point[/COLOR]




Set Sld = Nothing
Set pptPres = Nothing
Set pptApp = Nothing


End Function

 

[DanteAmor]

Try this:

    Selection.Cut
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Merge_Shapes ''''' go to Power Point to merge shapes
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
[COLOR=#0000cd]    DoEvents[/COLOR]
[COLOR=#0000cd]    Application.Wait (Now + TimeValue("00:00:05")) 'delay 5 seconds[/COLOR]
[COLOR=#0000cd]    DoEvents[/COLOR]
    
    .Paste ''' how to delay Paste untill Merge_Shapes complete and cut then Paste

 

[Dossfm0q]

Thanks sir and now wors with declare Sld as object By
Replacing: '.Shapes.Range(Array("MyRectangle", "Oval")).MergeShapes (msoMergeCombine)
with: pptApp.CommandBars.ExecuteMso ("ShapesCombine")

Sub CombineShapes()


Dim WB As Workbook
Dim WS As Worksheet
Dim Shp As Shape, Rctangl As Shape, Ovl As Shape, MergeShape As Shape
Dim Shps As Variant
Dim Names(1 To 2) As Variant
Set WB = ThisWorkbook 'Set WB = Workbooks("WorkbookName")
Set WS = WB.ActiveSheet 'Set WS = WB.WorkSheets("WorkSheetName")


With WS
    For Each Shp In .Shapes
        Shp.Delete
    Next
    
   ' Add Shape
    Set Rctngl = WS.Shapes.AddShape(msoShapeRectangle, 100, 100, 125, 200)
        With Rctngl
            .Name = "MyRectangle"
            Names(1) = .Name
            Lft = .Left
            Tp = .Top
            
        End With
   ' Add Hole
    Set Ovl = WS.Shapes.AddShape(msoShapeOval, Rctngl.Left + (Rctngl.Width * 0.5) - 15, Rctngl.Top + 15, 30, 30)
        With Ovl
            .Name = "Oval"
            Names(2) = .Name


        End With
     Set Shps = .Shapes.Range(Names)
    With Shps '.Shapes.Range(Names)
    
    .Select
    End With
    
    Selection.Cut
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
     Merge_Shapes.Cut ''''' go to Power Point to merge shapes
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


    DoEvents
    Application.Wait (Now + TimeValue("00:00:05")) 'delay 5 seconds
    DoEvents
 
    .Paste
        Set MergeShape = .Shapes(.Shapes.Count) ''' how to delay Paste untill Merge_Shapes complete and cut then Paste
            With MergeShape
            .Left = Lft
            .Top = Tp
                    With .Line
                    .ForeColor.RGB = RGB(255, 0, 0)
                    .Weight = 3
                    End With
                    With .Fill
                    .ForeColor.RGB = RGB(255, 255, 0)
                    End With
            End With


End With 'WS


 
End Sub
Public Function Merge_Shapes() As Object


Dim pptApp As Object
Dim pptPres As Object
Dim Sld As Object
Dim Visibility As Boolean
'Visibility = msoFalse ' To   pptApp Hide
Visibility = msoTrue ' to appear pptApp
    
    On Error Resume Next
        Set pptApp = Nothing
        Set pptApp = CreateObject("Powerpoint.Application")
        
        pptApp.Visible = Visibility ' To pptApp Hide
        If Visibility = msoTrue Then pptApp.Activate ' To pptApp Hide
        
        Set pptPres = pptApp.Presentations.Add(WithWindow:=Visibility) ' To keep pptApp Hide
        Set pptLayout = pptPres.Designs(1).SlideMaster.CustomLayouts(7)
        Set Sld = pptPres.Slides.AddSlide(1, pptLayout)
        pptApp.Visible = msoFalse
    
    On Error GoTo 0
    
        With Sld
                .Shapes.Paste '.Select 'for PowerPoint dot Shapes dot Paste
        
                .Shapes.Range(Array("MyRectangle", "Oval")).Select
                pptApp.CommandBars.ExecuteMso ("ShapesCombine")
                '.Shapes.Range(Array("MyRectangle", "Oval")).MergeShapes (msoMergeCombine)
        
            Set Merge_Shapes = .Shapes(.Shapes.Count)   ' cut to be pasteed on Excel
        End With


  pptApp.Quit ' close Power Point




Set Sld = Nothing
Set pptPres = Nothing
Set pptApp = Nothing


End Function

 

[DanteAmor]

You're welcome.