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)
Related
I use VBA to export data from XL to PPT. In windows it works fine. But When I use same code in MAC OS. I get error in this line..
Set pPres = pptApp.Presentations.Open(currentPath & Application.PathSeparator & pptname, msoFalse, msoCTrue, msoCTrue)
Dim pptApp As Object
Dim pPres As Object
Dim xl As Excel.Workbooks
Dim ws As Worksheet
Dim sldrange As Object
Dim sld As Object
Dim pattrenSlide As Object
Dim WorkSheetRange As Range
Sub Export()
'both file names and path
Dim wkname, pptname, currentPath As String
'Other Values
pptname = "Template.pptx"
currentPath = ThisWorkbook.Path
'Ópening Powerpoint
Set pptApp = CreateObject("Powerpoint.Application")
Set pPres = pptApp.Presentations.Open(currentPath & Application.PathSeparator & pptname, msoFalse, msoCTrue, msoCTrue)
'Opening Excel
Set wk = ThisWorkbook
Can anyone help me please?
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 have a question regarding the following code. The code now works, but did not until I set the Variables to nothing (see the part with the *** in the code). I got all kinds of error-messages (e.g. "462 The remote server machine does not exist or is unavailable")
My question is: Why do I have to Set those Variables to nothing? I guess it has something to do with the fact that I use a loop right?
Thanks in advance!
Sub Saveas_PDF()
Dim PP As PowerPoint.Presentation
Dim prs As PowerPoint.Presentation
Dim Sl As PowerPoint.Slide
Dim sh As Variant
Dim company As String
Set Dropdown.ws_company = Tabelle2
company = Dropdown.ws_company.Range("C2").Value
Dim strPOTX As String
Dim strPfad As String
Dim pptApp As Object
Call filepicker
Dim Cell As Range
For Each Cell In Dropdown.ws_company.Range(Dropdown.ws_company.Cells(5, 3),
Dropdown.ws_company.Cells(Rows.Count,
3).End(xlUp)).SpecialCells(xlCellTypeVisible)
Dropdown.ws_company.Range("C2") = Cell
Set pptApp = New PowerPoint.Application
Dim pptVorlage As String
pptVorlage = myfilename
Set PP = pptApp.Presentations.Open(pptVorlage)
PP.UpdateLinks 'Datei --> Informationen --> Verknüpfungen --> Automatisch
aktualisieren Haken setzen
Dim newpath As String
newpath = Replace(myfilename, "AXO", "" & Cell & " AXO")
Dim newpathpdf As String
newpathpdf = Replace(newpath, "pptx", "pdf")
PP.ExportAsFixedFormat "" & newpathpdf & "", ppFixedFormatTypePDF,
ppFixedFormatIntentPrint
pptApp.Visible = True
Debug.Print (PP.Name)
AppActivate (PP.Name)
PP.Close
***Set pptApp = Nothing
Set PP = Nothing***
Next
Set pptApp = New PowerPoint.Application
If IsAppRunning("PowerPoint.Application") Then
If pptApp.Windows.Count = 0 Then
pptApp.Quit
End If
End If
End Sub
Maybe because you are calling the constructor "New" inside de loop in the line: Set pptApp = New PowerPoint.Application
Move the line "Set pptApp = New PowerPoint.Application" before de foreach and try it.
I'm relatively new to VBA. I'm trying out the following VBA code but its throwing an error: 'Runtime error 09: subscript out of range'. This error occurs when i'm trying the paste operation in Graph 1 section of the code..
can someone help with figuring out as to where i'm going wrong. I have declared the presentation/slide etc. still i'm facing this problem..
Sub UK()
Dim oPPTApp As PowerPoint.Application
Dim oPPTFile As PowerPoint.Presentation
Dim oPPTShape As PowerPoint.Shape
Dim oPPTSlide As PowerPoint.Slide
Dim SlideNum As Integer
Dim mycells As Range
Set oPPTApp = CreateObject("PowerPoint.Application")
srcdir = "D:\WBR\Week 2"
srcfile = srcdir & "\" & Dir(srcdir + "\*.pptx")
Set oPPTFile = oPPTApp.Presentations.Open(srcfile)
Set oPPTSlide = oPPTFile.Slides(2)
' for graph 1
Set oPPTShape = oPPTFile.Slides(2).Shapes("Picture 3")
oPPTShape.Delete
ThisWorkbook.Sheets("New Charts").Activate
Sheets("New Charts").Shapes.Range(Array("Group 21")).Select
Selection.CopyPicture
oPPTApp.ActivePresentation.Slides(2).Select
Set Picture = oPPTSlide.Shapes.Paste
Picture.Name = "Picture 3"
With oPPTApp.ActivePresentation.Slides(2).Shapes("Picture 3")
.Top = Application.InchesToPoints(3)
.Left = Application.InchesToPoints(0.22)
End With
If I understand you correctly, you want to:
Open a saved presentation
Delete "Picture 3" from Slide 2
Copy Chart/Range from your excel sheet
Paste it in Slide 2
Name it as "Picture 3"
Set it's position on the slide
Well the below code does exactly that:
'Make Sure to load the PowerPoint Object Library
'Tools ---> References ---> Microsoft PowerPoint xx.x Object Library
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim objChart As Chart
Set pptApp = New PowerPoint.Application
'presentation path here
srcdir = "C:\"
Set pptPres = pptApp.Presentations.Open(srcdir & "Presentation" & ".pptx")
Set pptSlide = pptPres.Slides(2)
For j = 1 To pptSlide.Shapes.Count
With pptSlide.Shapes(j)
If .Name = "Picture 3" Then
.Delete
End If
End With
Next j
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Change "Chart 1" to the name of your chart if you are copying a chart
Worksheets("New Charts").ChartObjects("Chart 1").Activate
Set objChart = Worksheets("New Charts").ChartObjects("Chart 1").Chart
objChart.CopyPicture
'If you are copying a range of cells then use
Worksheets("New Charts").Range("A1:A10").Copy
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set MyPic = pptSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
With MyPic
.Name = "Picture 3"
End With
With pptSlide.Shapes("Picture 3")
.Top = Application.InchesToPoints(3)
.Left = Application.InchesToPoints(0.22)
End With
'use this line to set focus to slide 2 if you want to
pptPres.Slides(2).Select
pptPres.Save 'use this line to save if you want to
Set pptSlide = Nothing
Set pptPres = Nothing
Set pptApp = Nothing
I have a macro that basically is supposed to copy ranges from excel spreadsheets and then paste them into a powerpoint file. So one excel sheet per slide.
Here is my macro so far:
Option Explicit
Sub ExportToPPT()
Dim PPAPP As PowerPoint.Application
Dim PPRES As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim ppSRng As PowerPoint.ShapeRange
Dim XLAPP As Excel.Application
Dim XLwbk As Excel.Workbook
Dim xlWst As Excel.Worksheet
Dim XLRng As Excel.Range
Dim ppPathFile As String
Dim ppNewPathFile
Dim chartNum As Integer
Dim maxCharts As Integer
Debug.Print vbCrLf & " ---- EXPORT EXCEL RANGES POWERPOINT ----"
Debug.Print Now() & " - Exporting ranges to .ppt"
'CHANGE WHEN ADDING CHARTS - MUST ALSO ADD SLIDE to .PPT and change loop
Dim chartRng(1 To 9) As Excel.Range
Dim SlideNum As Integer
Dim SlideOffset As Integer
Set XLwbk = Excel.ActiveWorkbook
Set xlWst = XLwbk.Sheets("Test1")
'This accounts for the title slide and any others before the automatedpaste
SlideOffset = 1
Set chartRng(1) = XLwbk.Sheets("Test1").Range("A1:B15")
Set chartRng(2) = XLwbk.Sheets("Test2").Range("A1:E33")
Set chartRng(3) = XLwbk.Sheets("Test3").Range("A1:E33")
Set chartRng(4) = XLwbk.Sheets("Test4").Range("A1:E4")
Set chartRng(5) = XLwbk.Sheets("Test5").Range("A1:J14")
Set chartRng(6) = XLwbk.Sheets("Test6").Range("A1:I33")
Set chartRng(7) = XLwbk.Sheets("Test7").Range("A1:I11")
Set chartRng(8) = XLwbk.Sheets("Test8").Range("A1:I8")
' Create instance of PowerPoint
Set PPAPP = CreateObject("Powerpoint.Application")
PPAPP.Visible = True
' Open the presentation (Same folder as the Excel file)
ppPathFile = ActiveWorkbook.Path + "TestPPT.pptx"
Debug.Print ppPathFile
Set PPRES = PPAPP.Presentations.Open(ppPathFile)
PPAPP.ActiveWindow.ViewType = ppViewSlide
chartNum = 1
'Loop through all chart ranges
'CHANGE WHEN ADDING CHARTS
For chartNum = 1 To 9
SlideNum = chartNum + SlideOffset
Debug.Print "Chart number " & chartNum & " to slide number " & SlideNum
' Copy the range as a picture
chartRng(chartNum).CopyPicture Appearance:=xlScreen, Format:=xlPicture
'PowerPoint operations
Set PPSlide = PPAPP.ActivePresentation.AddSlide(1, _ **//New code**
PPAPP.ActivePresentation.SlideMaster.CustomLayouts.Item(2))
Debug.Print PPSlide.Name
PPSlide.Select
PPAPP.ActiveWindow.ViewType = ppViewSlide
'ppapp.ActivePresentation.Slides.
' Paste the range
'PPAPP.ActiveWindow.View.Slide (SlideNum)
PPAPP.ActiveWindow.View.Paste
'PPSlide.Shapes.Paste
'PPSlide.Shapes(0).Select
'PPSlide.Shapes.Paste.Select
' Align the pasted range
Set ppSRng = PPAPP.ActiveWindow.Selection.ShapeRange
With ppSRng
.LockAspectRatio = msoTrue
If (.Width / .Height) > 1.65 Then
.Width = 650
Else
.Height = 400
End If
End With
With ppSRng
'.Width = 650
.Align msoAlignCenters, True
.Align msoAlignMiddles, True
.IncrementTop 1.5
End With
Next chartNum
PPAPP.ActivePresentation.Slides(1).Select
PPAPP.ActiveWindow.ViewType = ppViewNormal
PPAPP.Activate
ppNewPathFile = ActiveWorkbook.Path & "\Test\TestPPT.pptx" & Format(Now(), "yyyymmdd_hhmmss")
PPAPP.ActivePresentation.SaveAs ppNewPathFile, ppSaveAsDefault
Debug.Print Now() & " - Finished"
End Sub
When I run the Macro it opens PowerPoint but stops and I get the following Error:
And when I debug it stops at this line:
Set PPSlide = PPAPP.ActivePresentation.Slides(SlideNum)
Any help on how to fix this would be great guys.
The error points to a counting problem that you've introduced in your code. Apparently, during the first iteration, it attempts to choose the second slide of a one-slide presentation (the second slide does not exist) and throwing an error.
I would assume this occurs because of your SlideOffset variable. Consider first adding a slide using before running Set PPSlide = PPAPP.ActivePresentation.Slides(SlideNum). Something like this:
Set pptLayout = PPAPP.ActivePresentation.Slides(1).CustomLayout
Set pptSlide = PPAPP.ActivePresentation.Slides.AddSlide(2, pptLayout)
Try using this
Set PPSlide = PPAPP.ActivePresentation.AddSlide(1, _
PPAPP.ActivePresentation.SlideMaster.CustomLayouts.Item(2))