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
Related
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
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 using Late Binding to Copy Charts and Range from Excel to PowerPoint.
I am getting the following error:
At the this line of code:
Set myShape = ppSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile, msoFalse)
Note: I am using the Range.Copy and Shapes.PasteSpecial as ppPasteEnhancedMetafile since after a lot of trial and error it gives the best resolution in PowerPoint.
Note #2: Using this PasteSpecial as ppPasteEnhancedMetafile worked fine for me when I was using Early Binding. I had to switch to Late Binding due to the fact that we have users running Office 2010, Office 2013 and Office 2016 (and I don't want them playing with the VB Project Ref. to the PowerPoint Library).
My Code
Option Explicit
Public Sub UpdatePowerPoint(PowerPointFile)
Dim ppProgram As Object
Dim ppPres As Object
Dim CurOpenPresentation As Object
Dim ppSlide As Object
Dim myShape As Object
Dim SlideNum As Integer
Dim StageStat As String
On Error Resume Next
Set ppProgram = GetObject(, "PowerPoint.Application")
On Error GoTo 0
If ppProgram Is Nothing Then
Set ppProgram = CreateObject("PowerPoint.Application")
Else
If ppProgram.Presentations.Count > 0 Then
For Each CurOpenPresentation In ppProgram.Presentations ' loop through all open presnetations (check Full Name: Path and name)
Dim CleanFullName As String * 1024
CleanFullName = Replace(CurOpenPresentation.FullName, "%20", " ") ' replace Sharepoint characters %20 with Space (" ")
Dim comStr As String * 1024
comStr = CStr(PowerPointFile)
If StrComp(comStr, CleanFullName, vbTextCompare) = 0 Then
Set ppPres = CurOpenPresentation
Exit For
End If
Next CurOpenPresentation
End If
End If
If ppPres Is Nothing Then ' if One-Pager presentation was not found from all open presentations
Set ppPres = ppProgram.Presentations.Open(PowerPointFile, msoFalse)
End If
ppProgram.Visible = True
SlideNum = 1
Set ppSlide = ppPres.Slides(SlideNum) ' set the slide
' --- loop throughout the Slide shapes and search for the Shape of type chart , then delete the old ones
For i = ppSlide.Shapes.Count To 1 Step -1
If ppSlide.Shapes.Item(i).HasChart Or ppSlide.Shapes.Item(i).Type = msoEmbeddedOLEObject Or ppSlide.Shapes.Item(i).Type = msoPicture Then
ppSlide.Shapes.Item(i).Delete
End If
Next i
' copy range from Excel Sheet
OnePgrSht.Range("A1:Q33").Copy
' ***** Error at the line below *****
Set myShape = ppSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile, msoFalse) ' Paste to PowerPoint
' Set Pasted Picture object properties:
With myShape
.LockAspectRatio = msoFalse
.Width = ExcelPicObj_Width
.Height = ExcelPicObj_Height
.Left = ExcelPicObj_Pos_Left
.Top = ExcelPicObj_Pos_Top
.ZOrder msoSendToBack
End With
ppPres.Save
OnePgrSht.Activate ' <-- restore mouse focus on "One-Pager" sheet
Set ppSlide = Nothing
Set ppPres = Nothing
Set ppProgram = Nothing
End Sub
The ppPasteEnhancedMetafile is a PowerPointconstant which is not available using late binding. This is because late binding does not include the PowerPoint library in which this constant is defined.
So you have to use
Set myShape = ppSlide.Shapes.PasteSpecial(2, msoFalse)
where 2 = ppPasteEnhancedMetafile.
I am trying to convert all pptx files in a give path to pdf files.
my code:
Sub pptxtopdf()
Dim ppt As Object
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
On Error Resume Next
Set ppt = GetObject(, "PowerPoint.Application")
If ppt Is Nothing Then
Set ppt = CreateObject("PowerPoint.Application")
End If
On Error GoTo 0
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("P:\Operations\Data & Deliverables\Projects\Amica\presentation_workspace\1_ spring 2015\Presentations\Volvo")
i = 1
'loops through each file in the directory
For Each objFile In objFolder.Files
Set WDReport = ppt.Presentations.Open(objFile.Path)
Dim FileName2 As String
FileName2 = Replace(objFile.Path, "pptx", "pdf")
'WDReport.ExportAsFixedFormat FileName2, ppFixedFormatTypePDF
WDReport.SaveAs FileName2, ppSaveAsPDF
WDReport.Close
ppt.Quit
Set ppt = Nothing
Set WDReport = Nothing
i = i + 1
Next objFile
End Sub
error msg
Presentation.SaveAs : Invalid enumeration value.
Cannot see what I'm doing wrong?
same problem as here but the solution didnt work for me - Excel macro to save pptx as pdf; error with code
You are late binding PowerPoint.Application so its enumeration values are not exposed or available in the global VBA namespace.
As you have not added option explicit to warn you of undeclared variables your use of the undeclared ppSaveAsPDF causes no error but has no value.
Add:
const ppSaveAsPDF as long = 32
To the top of the module to provide the expected value to SaveAs.