Copy and paste PPT

[vmjan02]

I have thsi code and it is perfect insted of picture is it a way that the code is to delete microsoft object and paste microsoft objevt,

but is there a way that insted of picture but

Sheets("Region").Select
    ActiveSheet.Shapes.Range(Array("Group 1a")).Select
    Selection.Copy
    'Set rng = ThisWorkbook.Sheets("Region").Range("A1:U37")
    
    Set mySlide = oPP.Slides(6)
    
    
    'Delete picture  insted microsoft object 
    Dim p As Long
    For p = mySlide.Shapes.Count To 1 Step -1
    Set PPShape = mySlide.Shapes(p)
    If PPShape.Type = msoPicture Then PPShape.Delete  
    Next
    
    
    'rng.Copy
    'mySlide.Shapes.PasteSpecial (ppPastePicture)
    mySlide.Shapes.PasteSpecial (ppPasteBitmap)  'insted microsoft object
    Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
        myShapeRange.LockAspectRatio = msoFalse
        myShapeRange.Left = 10
        myShapeRange.Top = 60
        myShapeRange.Height = 380   '380
        myShapeRange.Width = 495    '475
    Application.CutCopyMode = False
    
    oPP.Save
    oPP.Close

 

[Domenic]

What type of object do you have?

It looks like you may have groups of some sort. If this is the case, you can delete your groups as follows...

If PPShape.Type = msoGroup Then PPShape.Delete

And to paste your group...

mySlide.Shapes.PasteSpecial ppPasteShape

Hope this helps!

 

[vmjan02]

What type of object do you have?

It looks like you may have groups of some sort. If this is the case, you can delete your groups as follows...

If PPShape.Type = msoGroup Then PPShape.Delete

And to paste your group...

mySlide.Shapes.PasteSpecial ppPasteShape

Hope this helps!

I tried but getting this error

 

[Domenic]

You've declared your loop variable p as a Shape, yet you're assigning it a number. Hence the type mismatch error. You should declare it as Long...

Dim p as Long

 

[vmjan02]

Long

this is the entire code, still delete is not working.

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copy pasting the Map in PPT slides all 2
'
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


    Dim mySlide As PowerPoint.Slide
    Dim myShapeRange As PowerPoint.Shape
    
    Dim oPA As PowerPoint.Application
    Dim oPP As PowerPoint.Presentation
    Dim oPS As PowerPoint.SlideRange
    Dim strTemplate As String
    Dim rng As Range
    Dim Fname As String
        
    Fpath = ActiveWorkbook.Path
    
    strTemplate = Fpath & "\" & "Fixed Weekly Report - Master1.pptx"      ''"C:\Viral Shah\Automation\Weekly Report\Fixed Weekly Report.pptx"
    
    Set oPA = New PowerPoint.Application
    oPA.Visible = msoTrue
    'changed this line to assign the new presentation to your variable
    'Set oPP = oPA.Presentations.Open(strTemplate, untitled:=msoTrue)
    Set oPP = oPA.Presentations.Open(strTemplate)
        
    'If Not oPS Is Nothing Then Set oPS = Nothing
    'If Not oPP Is Nothing Then Set oPP = Nothing
    'If Not oPA Is Nothing Then Set oPA = Nothing
    
Err_PPT:
    If Err <> 0 Then
    MsgBox Err.Description
    Err.Clear
    Resume Next
    End If
    
    
    Sheets("OLTFinal Report").Select
    ActiveSheet.Shapes.Range(Array("Group 15a")).Select
    Selection.Copy
    'Set rng = ThisWorkbook.Sheets("Region").Range("A1:U37")
    
    Set mySlide = oPP.Slides(2)
    
    
    'Delete picture
    Dim p As Long
    For p = mySlide.Shapes.Count To 1 Step -1
    Set PPShape = mySlide.Shapes(p)
    'If PPShape.Type = Shape Then PPShape.Delete
    If PPShape.Type = msoPicture Then PPShape.Delete
    Next
    
    
    'rng.Copy
    'mySlide.Shapes.PasteSpecial (ppPastePicture)
    
    'mySlide.Shapes.PasteSpecial ppPasteOLEObject, msoCTrue
    mySlide.Shapes.PasteSpecial ppPasteShape
    'mySlide.Shapes.PasteSpecial (ppPasteBitmap)
'    Set myShapeRange(1) = mySlide.Shapes(mySlide.Shapes.Count)
'        myShapeRange(1).LockAspectRatio = msoFalse
'        myShapeRange(1).Left = 10
'        myShapeRange(1).Top = 60
'        myShapeRange(1).Height = 380   '380
'        myShapeRange(1).Width = 495    '475
    Application.CutCopyMode = False
    
'    oPP.Save
'    oPP.Close
    
End Sub

 

[Domenic]

As per my previous suggestion, try replacing...

If PPShape.Type = msoPictureThen PPShape.Delete

with

If PPShape.Type = msoGroup Then PPShape.Delete

If this still doesn't help, please confirm which type of object you have.

 

[vmjan02]

thanks a ton, missed this part. than you.

 

[Domenic]

You're very welcome. Glad I could help.

Cheers!

 

[vmjan02]

one qurierie

I am not able to do the left and top positions

mySlide.Shapes.PasteSpecial ppPasteShape  [B]' here the code ends its not executiong left and top positions[/B]
    'mySlide.Shapes.PasteSpecial (ppPasteBitmap)
    Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
        myShapeRange.LockAspectRatio = msoFalse
        myShapeRange.Left = 5
        myShapeRange.Top = 30
'        myShapeRange(1).Height = 380   '380
'        myShapeRange(1).Width = 495    '475

 

[Domenic]

ActiveSheet.Shapes.Range(Array("Group 15a")).Select

First, can you please confirm the type of object that the above line refers to? Also, it might help if you temporary removed the error handling from your code and run it again. This time when the error occurs your code should break and you should receive an error message. Can you tell us which error you're receiving and confirm which line is causing the error?