CODEWITHSUNDEEP
vbacopyingpasting
Yogwhatup
Yogwhatup

Reputation: 362

Copying picture from Excel to Powerpoint

This is the code I wrote to copy over a picture from Excel to PowerPoint. I have other code that preps the PowerPoint slide, which should have no factor on this. For some reason this code is not working. It is giving me the error that no slide is currently in view. Thanks in advance for the help.

Sub CopyPicToPPt()

Dim pptApp As PowerPoint.Application
Dim pptPresent  As Presentation
Dim sldPPT  As Slide
Dim shpPic As Shape
Dim oLayout As CustomLayout
Dim x As PowerPoint.Shape

ActiveWorkbook.Sheets("Sheet1").Select
Set shpPic = Sheet4.Shapes("Picture 3") '<< --- Pic Name

shpPic.CopyPicture

Set pptApp = GetObject(class:="PowerPoint.Application")

pptApp.Visible = True
pptApp.Activate

Set pptPresent = pptApp.ActivePresentation
Set sldPPT = pptApp.ActiveWindow.View.Slide



sldPPT.Shapes.PasteSpecial(ppPasteMetafilePicture).Select

pptApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = False
pptApp.ActiveWindow.Selection.ShapeRange.Left = 24
pptApp.ActiveWindow.Selection.ShapeRange.Top = 6
pptApp.ActiveWindow.Selection.ShapeRange.Height = 55
pptApp.ActiveWindow.Selection.ShapeRange.width = 672


End Sub

Upvotes: 1

Views: 2362

Answers (1)

Yogwhatup
Yogwhatup

Reputation: 362

After a little fiddling and some help from a friend I think I have it! - Cheers 

Sub CopyPicToPPt()

Dim pptApp As PowerPoint.Application
Dim pptPresent  As Presentation
Dim sldPPT  As Slide
Dim shpPic As Shape
Dim oLayout As CustomLayout
Dim x As PowerPoint.Shape

ActiveWorkbook.Sheets("Sheet1").Visible = True
ActiveWorkbook.Sheets("Sheet1").Select
Set shpPic = Sheet4.Shapes("Picture 3") '<< --- Pic Name

shpPic.CopyPicture

Set pptApp = GetObject(class:="PowerPoint.Application")

pptApp.Visible = True
pptApp.Activate

pptApp.ActivePresentation.Slides(1).Select

Set pptPresent = pptApp.ActivePresentation
Set sldPPT = pptApp.ActivePresentation.Slides(1)



sldPPT.Shapes.PasteSpecial(ppPasteMetafilePicture).Select

pptApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = False
pptApp.ActiveWindow.Selection.ShapeRange.Left = 24
pptApp.ActiveWindow.Selection.ShapeRange.Top = 6
pptApp.ActiveWindow.Selection.ShapeRange.Height = 55
pptApp.ActiveWindow.Selection.ShapeRange.width = 672
ActiveWorkbook.Sheets("Sheet1").Visible = False

End Sub

Upvotes: 1

Related Questions