I have a powerpoint presentation embedded in Excel which I am opening using a macro and then I would like to save the open presentation to the C Drive
I tried the below code but unable to save the powerpoint to the required destination.
Sub openppt()
Dim ppPres As PowerPoint.Presentation
Set ppApp = New PowerPoint.Application
Todate = Date
Sheets("SupportData").Select
ActiveSheet.Shapes.Range(Array("Object 7")).Select
Selection.Verb Verb:=3
activeSlide.SaveAs "C:\Release_Review\" & "Release_Review" & Todate &
".pptx"
End Sub
I would like the open slide to be saved in C:\Release_Review\ and then name should be Release_ReviewTodays_date
First, you can refer to your object using the OLEObject object. Secondly, 3 does not appear to be a valid verb. Try the following instead...
Sub openppt()
Dim oleObj As OLEObject
Set oleObj = Worksheets("SupportData").OLEObjects("Object 7")
oleObj.Verb xlVerbOpen
Dim pres As Object
Set pres = oleObj.Object
pres.SaveAs "C:\Release_Review\Release_Review" & Date & ".pptx"
End Sub
Related
Sub SendToPPT()
Dim ppt As Object
Set ppt = CreateObject("Powerpoint.Application")
ppt.Presentations.Open ActivePresentation.Path & "\" & "Allegation.pptx"
For i = 6 To 24
ppt.Slides(i).Shapes(1).TextFrame.TextRange = ActiveDocument.Paragraphs(i).Range.Text
Next i
ppt.Save
ppt.Close
Set ppt = Nothing
End Sub
I'm receiving a
Run time Error 424: Object Required.
I'm unable to figure out where I'm going wrong. The file path is correct, I've cross-checked it.
ppt is the "Powerpoint.Application" but ppt.Slides(i) expects a presentation not the powerpoint application.
Dim Pres As Object
Set Pres = ppt.Presentations.Open(ActivePresentation.Path & "\" & "Allegation.pptx")
Dim i As Long
For i = 6 To 24
Pres.Slides(i).Shapes(1).TextFrame.TextRange = ActiveDocument.Paragraphs(i).Range.Text
Next i
Pres.Save
Pres.Close
Set Pres = Nothing
Set ppt = Nothing
I am calling VBA code from an Excel spreadsheet to open an existing PowerPoint file via the Presentations.Open method. In my environment I developed via Early Binding using the MS PowerPoint 14.0 Object Library and the codes run without a problem.
However, when the script was called in another machine that runs MS Office 2013 (i.e. MS PowerPoint 15.0 Object Library), a Run-time error pops up
Method 'Open' of object 'Presentations' failed
Is the Presentations.Open method deprecated in PPT 15.0 Object library? I tried searching Internet but couldn't find documentation on the change.
I also attempted to use Late Binding to see if it works, but received the same error.
Please find below the code snipnets I used (early + late binding).
Thank you very much for the help.
Early Binding Code Snipnet
Sub EarlyBinding()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim PowerpointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Set PowerpointApp = New PowerPoint.Application
PowerpointApp.Visible = True
Dim myPath As String
myPath = ws.Range("wk_dir").Value & "\" & ws.Range("ppt_name").Value
Set myPresentation = PowerpointApp.presentations.Open(myPath)
myPresentation.SaveAs (ws.Range("wk_dir").Value & "\test_earlybind.pptx")
Set myPresentation = Nothing
Set PowerpointApp = Nothing
End Sub
Late Binding Code Snipnet
Sub LateBinding()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim PowerpointApp As Object
Dim myPresentation As Object
Set PowerpointApp = CreateObject("Powerpoint.Application")
PowerpointApp.Visible = True
Dim myPath As String
myPath = ws.Range("wk_dir").Value & "\" & ws.Range("ppt_name").Value
Set myPresentation = PowerpointApp.presentations.Open(myPath)
myPresentation.SaveAs (ws.Range("wk_dir").Value & "\test_latebind.pptx")
Set myPresentation = Nothing
Set PowerpointApp = Nothing
End Sub
I have a little issue with my macro. I know it's not the perfect one but at least it works.
The only thing is that when I go step by step it is going perfectly but when I run it all the new slides are blank.
Do you have an idea how to improve that ?
Sub paste_toPPT()
Dim PowerPointApp As Object
Dim pptApp As Object
Dim pptPres As Object
Dim myRange As Excel.Range
Dim path As String
Dim DestinationPPT As String
Dim saveName As String
Dim image As Object
Dim IDe As String
Dim count As Integer
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set pptApp = GetObject(Class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If pptApp Is Nothing Then Set pptApp = CreateObject(Class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Open template
DestinationPPT = "C:\Users\user\Desktop\ID Card\Kpi ID.pptx"
Set pptPres = pptApp.Presentations.Open(DestinationPPT)
Windows("KPI List - P2P KPI.xlsm").Activate
count = WorksheetFunction.CountA(Sheets("KPI List").Range("E:E")) - 1
For i = 8 To count
Worksheets("KPI List").Select
'ThisWorkbook.Sheets("KPI List").Select
IDe = Worksheets("KPI List").Range(Cells(i, 5), Cells(i, 5))
ThisWorkbook.Sheets("ID").Range("F4:F4") = IDe
'Set the range to copy
Windows("KPI List - P2P KPI.xlsm").Activate
Worksheets("ID").Select
Worksheets("ID").Shapes.Range(Array("Group 57")).Select
Selection.Copy
'Add slide & Paste data
pptPres.Windows(1).Activate
Set mySlide = pptPres.Slides.Add(1, 12)
mySlide.Select
pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
Next i
pptPres.SaveAs DestinationPPT
End Sub
Try the code below, explanations inside the code as comments:
Sub paste_toPPT()
Dim pptApp As Object
Dim pptPres As Object
Dim myRange As Excel.Range
Dim path As String
Dim DestinationPPT As String
Dim saveName As String
Dim image As Object
Dim IDe As String
Dim count As Integer
' added 2 worksheet objects
Dim wsKPI As Worksheet
Dim wsID As Worksheet
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set pptApp = GetObject(, "PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If pptApp Is Nothing Then Set pptApp = CreateObject("PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Open template
DestinationPPT = "C:\Users\user\Desktop\ID Card\Kpi ID.pptx"
Set pptPres = pptApp.Presentations.Open(DestinationPPT)
' no need to Activate the workbook first, just set the worksheet objects
Set wsKPI = Workbooks("KPI List - P2P KPI.xlsm").Sheets("KPI List")
Set wsID = Workbooks("KPI List - P2P KPI.xlsm").Sheets("ID")
count = WorksheetFunction.CountA(ws.Range("E:E")) - 1
For i = 8 To count
IDe = wsKPI.Range(wsKPI.Cells(i, 5), wsKPI.Cells(i, 5))
wsID.Range("F4:F4") = IDe
' first add the slide , later do the copy>>paste as close as can be
Set mySlide = pptPres.Slides.Add(1, 12)
' Set the range to copy (no need to Select first)
wsID.Shapes.Range(Array("Group 57")).Copy
mySlide.Select
pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
Next i
pptPres.Save
End Sub
I am creating a PowerPoint each week from some charts in Excel using VBA. However, the first slide needs to come from lasts week PowerPoint created.
The file path and name are both variables because they have the date in their title. I am able to account for this and have checked it with the actual file's name. It looks the same to me. However when I try to Open the file I get the ActiveX error/Run-time error 429. Any ideas would be much appreciated
Sub CreateNewPres()
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim objPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Dim ppTextbox As PowerPoint.Shape
Set ppApp = New PowerPoint.Application
ppApp.Visible = True
ppApp.Activate
Set ppPres = ppApp.Presentations.Add
todayDate = Date
myTextDate = Format(todayDate, "yyyy-mm-dd")
myFilePath = "C:\Desktop\Main\" & myTextDate
myFileName = "\Meeting_" & myTextDate & ".pptx"
myFile = myFilePath & myFileName
objPres=_
Presentations.Open(myFile)
objPres.Slides(1).Copy
ppPres.Slides.Paste (ppPasteEnchancedMetafile)
Set ppTextbox = ppSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, _
Left:=0, Top:=0, Width:=30, Height:=10)
With myTextBox.TextFrame.TextRange.Text = todayDate
End With
Change this line:
objPres = Presentations.Open(myFile)
to this:
Set objPres = ppApp.Presentations.Open(myFile)
I want to use a template to copy data from EXCEL to a POWERPOINT presentation with EXCEL VBA. It works when I use an explicit path. However I want to use a relative path to run it, but its throw me the following error
Sub PowerPoint()
Dim rng As Excel.Range
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.Shape
Dim Template As String
'Copy Range from Excel
Set rng = Worksheets("Contact Page").Range("C2:O38")
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Create a New Presentation
Template = CurDir()
Template = Template & "\TEMPLATE3.potm"
Set myPresentation = PowerPointApp.Presentations.Add
myPresentation.ApplyTemplate (Template)
'myPresentation.ApplyTemplate ("C:\Users\Oriol\Documents\3mundi\Reporting\BR\New Model\TEMPLATE3.potm")
myPresentation.PageSetup.SlideSize = ppSlideSizeOnScreen
Error
What Should I do?
Assuming the template file is in the same folder of the Excel file, change the statement:
Template = CurDir()
to:
Template = ThisWorkbook.Path
Is the Excel file in the same locations as your potm? CurDir() returns the path that the excel file is currently saved in. So if your potm is saved in a subfolder, you will want to use that sub-folder in the path as well:
Template = CurDir()
Template = Template & "\SubFolder\TEMPLATE3.potm"