VBA Copy Pictures from Excel and Paste them in PowerPoint

[Magdoulin]

Hi Guys, how is everything?
I have excel sheet contains 3 pictures, Picture1, Picture2 and Picture3.

How to write VBA code to open specific existing PowerPoint file, delete any pictures in this PowerPoint file first, and then to copy Picture1 and paste in slide 2, Picture2 in slide 5 and Picture3 in slide 8.


P.S. This topic was originally posted in Ozgrid forum with this link:
https://www.ozgrid.com/forum/forum/help-forums/excel-vba-macros/1205805-copy-pictures-from-excel-and-paste-them-in-powerpoint

 

[MUKESHY12390]

here you go...

Sub ppt()
Dim oppApp As PowerPoint.Application
Dim oppt As Presentation
Dim osilde As Slide
'(.pptx)


Set oppApp = New PowerPoint.Application
oppApp.Visible = msoCTrue
Set oppt = oppApp.Presentations.Add
Set oslide = oppt.Slides.Add(1, ppLayoutBlank)


'''''''create chart and name it chart2 in sheet2
Sheet2.ChartObjects("Chart 2").Copy


oppApp.ActivePresentation.Slides(1).Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile).Select


'''here you change chart size
With oppApp.ActiveWindow.Selection.ShapeRange
    LockAspectRatio = 1
    .Left = 50
    .Top = 50
    .LockAspectRatio = 0
    .Height = 200
    .Width = 250
End With


End Sub

 

[Magdoulin]

Great! Thanks
However here's the case
I need to use regularly an existing PowerPoint file with known location path
Not to create one
And the other thing I want the Excel VBA to delete any existing picture first from this PowerPoint file before starting to paste the new ones to it
How to do that?

 

[MUKESHY12390]

Sub PPT_Autom()
Dim ObjPPT As PowerPoint.Application
Dim oPresentation As PowerPoint.Presentation
Dim oslide As PowerPoint.Slide
Dim oshape As PowerPoint.Shape
Dim i As Long
Dim opath As String


opath = "D:\Training\mrexcel\mks1.pptx"
Set ObjPPT = New PowerPoint.Application
ObjPPT.Visible = msoCTrue
Set oPresentation = ObjPPT.Presentations.Open(opath, msoCTrue)
'Set oslide = oPresentation.Slides.Add(oPresentation.Slides.Count + 1, ppLayoutBlank)
'Set oslide = oPresentation.Slides.Add(oPresentation.Slides.Count + 1, ppLayoutBlank)


For Each oslide In oPresentation.Slides
        For Each oshape In oslide.Shapes
            oshape.Delete
        Next oshape
Next oslide


Sheet1.ChartObjects("Chart 1").Copy


ObjPPT.Activate
'''requir to select shape in particular slide
ObjPPT.ActiveWindow.View.GotoSlide (2)
ObjPPT.ActivePresentation.Slides(2).Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select


'''here you change chart size
With ObjPPT.ActiveWindow.Selection.ShapeRange
    .LockAspectRatio = False
    .Left = 50
    .Top = 50
    .LockAspectRatio = False
    .Height = 300
    .Width = 300
End With


Set oslide = Nothing
Set oPresentation = Nothing




End Sub

 

[MUKESHY12390]

I have not tested .... just added loop to delete shape/ view.goto line.

 

[MUKESHY12390]

replace old one with these

'''' old one
For Each oslide In oPresentation.Slides
        For Each oshape In oslide.Shapes
            oshape.Delete
        Next oshape
Next oslide

'--New
Dim i As Long
For Each oSlide In oPresentation.Slides
    For i = oSlide.Shapes.Count To 1 Step -1
            oSlide.Shapes(i).Delete
    Next i
Next oSlide