Export to PowerPOint using Excel VBA

bronc

New Member
Joined
Aug 28, 2003
Messages
22
I use the following code in an attempt to transfer the sheet named Sector Attrib which contains a table anda chart and various other objects. I am trying to transfer the whole sheet but find that only the first object on the sheet which happens to be a table is transferred to the powerpoint slide.
I am at a loss to know why it transfers just the first object and not the whole sheet. Thanks.

Private Sub cmdUseOLEWithFileName_Click()
Dim newSlide As PowerPoint.slide
Dim sh As PowerPoint.shape
Dim excelWB As Workbook
Dim shtName As String
Dim objOLE As Object
Dim xlFilePath As String

Set newSlide = GetNewSlide() ' New blank slide for "MyPresentation.pptx" open or not.
Set excelWB = ActiveWorkbook
shtName = "Sector Attrib"
xlFilePath = excelWB.Path & "\" & excelWB.Name
Worksheets(shtName).Activate
newSlide.Shapes.AddOLEObject Left:=50, top:=50, Width:=600, Height:=250, Filename:=xlFilePath, Link:=False
Set excelWB = Nothing
Set newSlide = Nothing
End Sub

' The below code which is called from above simply opens powerpoint if not open etc and makes a new slide:

Function GetNewSlide(Optional layOutType = PowerPoint.PpSlideLayout.ppLayoutBlank) As PowerPoint.slide
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.slide
Dim FileAndPath As String
FileAndPath = "C:\Users\User\Desktop\L&P\MyPresentation.pptx" ' Get this from the s/sheet??
On Error Resume Next
' Check if PowerPoint is already open
Set pptApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0

' If PowerPoint is not open, create a new instance
If pptApp Is Nothing Then
Set pptApp = New PowerPoint.Application
End If

' Set error handling to resume next in case of any errors during presentation open
On Error Resume Next

' Check if the presentation is already open
Set pptPres = Nothing
On Error Resume Next
Set pptPres = pptApp.Presentations("MyPresentation.pptx")
On Error GoTo 0
' If the presentation is not open, open it
If pptPres Is Nothing Then
Set pptPres = pptApp.Presentations.Open(FileAndPath)
End If
' Show the PowerPoint application
pptApp.Visible = True

' Add a new slide to the presentation
' This adds to position 1.
Set pptSlide = pptPres.Slides.Add(1, layOutType)
Set GetNewSlide = pptSlide
' Clean up objects
' Set pptSlide = Nothing
' Set pptPres = Nothing
' Set pptApp = Nothing

End Function
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).

Forum statistics

Threads
1,215,072
Messages
6,122,966
Members
449,094
Latest member
Anshu121

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top