I'm trying to copy slide 1 from external ppt to current ppt into notes page. However, I'm getting this error msg:
Slides (unknown member) : Invalid request. Clipboard is empty or
contains data which may not be pasted here.
The external ppt from where I'm copying does contains the data.
VBA script:
Sub copySlide()
Dim objPresentation As Presentation
Set objPresentation = Presentations.Open("/path/slides.ppt")
objPresentation.Slides.Item(1).Copy
Presentations.Item(1).Slides.Paste
objPresentation.Close
End Sub
Try the code below, I hope your presentation at ("/path/slides.ppt") doesn't throw an error.
I added 2 options, either place it at the end, or as the second slide - you can modify the Paste line easily
Code
Sub copySlide()
Dim MyPres As Presentation
Dim objPresentation As Presentation
Set MyPres = ActivePresentation
Set objPresentation = Presentations.Open("/path/slides.ppt")
objPresentation.Slides(1).Copy
'MyPres.Slides.Paste MyPres.Slides.Count + 1 ' <-- place it at the end
MyPres.Slides.Paste 2 ' <-- place it as the second slide
objPresentation.Close
Set objPresentation = Nothing ' clear object
End Sub
Related
I am a beginner in this matter, could you help me, please?
In PowerPoint, I made code linked to a CommandButton that opens a workbook, when I click on it, Excel opens, but it is flashing on the taskbar and the PowerPoint Presentation remains open. It is possible when clicking on the button Excel opens in front of the Presentation?
Private Sub cmbFAUUSP_Click()
Dim ExcApp As Excel.Application
Set ExcApp = New Excel.Application
ExcApp.Visible = True
ExcApp.Workbooks.Open ("C:\Users\Monster PC\Desktop\tabeladedisciplinas FAUUSP.xlsx")
Set pastatrabalho = ExcApp.ActiveWorkbook
pastatrabalho.Application.ActiveWindow.WindowState = xlMaximized
pastatrabalho.Application.DisplayFullScreen = True
End Sub
If you have not, you should declare all your variables. (Use Option Explicit at the top of the module to help you with that, it will warn you if you forgot to declare a variable)
You don't need to set workbook for what you described so I have commented pastatrabalho, uncomment/remove as you need:
Private Sub cmbFAUUSP_Click()
Dim ExcApp As Excel.Application
Dim pastatrabalho As Excel.Workbook 'Uncomment / Remove as needed
On Error Resume Next
Set ExcApp = GetObject(, "Excel.Application") 'This will retrieve the existing instance of Excel if you already have an Excel running
On Error GoTo -1
If ExcApp Is Nothing Then Set ExcApp = New Excel.Application 'Create a new instance of Excel if not
ExcApp.Workbooks.Open ("C:\Users\Monster PC\Desktop\tabeladedisciplinas FAUUSP.xlsx")
'Replace above line with below if you need to refer to the workbook in the later part of your procedure, if any
'Set pastatrabalho = ExcApp.Workbooks.Open ("C:\Users\Monster PC\Desktop\tabeladedisciplinas FAUUSP.xlsx")
With ExcApp
'Setting Left and Top will brings Excel window to the same location as your Powerpoint (applicable if using multiple monitors)
.Left = Application.Left
.Top = Application.Top
.Visible = True
.WindowState = xlMaximized
.DisplayFullScreen = True
.ActiveWindow.Activate
'AppActivate ExcApp.Caption 'another way of activating, must provide the exact same title as the one shown on your Application (which can differ based on version)
End With
End Sub
I want to remove read-only using a PowerPoint macro.
I'm writing a macro that fires when a file is opened.
In that macro, there is a process to delete a specific shape.
The PowerPoint file has a write lock.
Given the above assumptions, when you open the file read-only
The macro will be executed, but an error will occur because it is read-only and the shape cannot be deleted.
So I unlock the read-only lock when the macro is executed
When I'm done deleting a particular shape, I want to lock it again for read-only.
Is there such a way?
I know the write lock password.
Public Sub Ribbon_onLoad(ribbon As IRibbonUI)
Const EXP_DATE As Date = "2021/09/30"
Dim NOW_DATE As Date: NOW_DATE = Format(Date, "yyyy/mm/dd")
Dim pp As PowerPoint.Presentation: Set pp = ActivePresentation
If NOW_DATE <= EXP_DATE Then
MsgBox "OK!"
Call DeleteShapesWithName("expShape")
Else
MsgBox "No!Exp!：" + Format(EXP_DATE, "yyyy/mm/dd")
'ActivePresentation.Close
End If
End Sub
Sub DeleteShapesWithName(ByVal targetName As String)
Dim sld As Slide
Dim shp As Shape
Dim i As Long
i = 1
For Each sld In Application.ActivePresentation.Slides
Do Until i > sld.Shapes.Count
If sld.Shapes(i).Name = targetName Then
sld.Shapes(i).Delete
Else
i = i + 1
End If
Loop
Next
End Sub
------add
I added the modified source after receiving the reply.
Public Sub Ribbon_onLoad(ribbon As IRibbonUI)
Call UnlockPresentation
End Sub
Sub UnlockPresentation()
Dim oPVW As ProtectedViewWindow
Dim oPres As Presentation
Set oPVW = ProtectedViewWindows.Open("C:\test\example_exp.pptm")
oPVW.Edit ModifyPassword:="test"
Call DeleteShapesWithName("expShape")
'Do stuff here
End Sub
Sub DeleteShapesWithName(ByVal targetName As String)
Dim sld As Slide
Dim shp As Shape
Dim i As Long
i = 1
For Each sld In Application.ActivePresentation.Slides
Do Until i > sld.Shapes.Count
If sld.Shapes(i).Name = targetName Then
sld.Shapes(i).Delete
Else
i = i + 1
End If
Loop
Next
End Sub
Here's code to open a read-only presentation so you can modify it. No need to reset the password, just replace "Test" with the actual password. Where the Do stuff here comment is, you can use the ActivePresentation keyword to modify the file:
Sub UnlockPresentation()
Dim oPVW As ProtectedViewWindow
Dim oPres As Presentation
Set oPVW = ProtectedViewWindows.Open("C:\HasModPW.pptx")
oPVW.Edit ModifyPassword:="ExistingModificationPassword"
'Do stuff here
End Sub
Please note: Microsoft's help page on ProtectViewWindow.Edit is wrong. The page currently states this method changes the password, but it actually provides the PW to make editing possible,
We typically use powerpoint to facilitate our experiments. We use "sections" in powerpoint to keep groups of slides together for each experimental task. Moving the sections to counterbalance the task order of the experiment has been a lot of work!
I thought we might be able to predefine a counterbalance order (using a string of numbers representing the order) in a CSV or array (haven't built that out yet in VBA). Then using VBA to move the sections and save the file for each order. I am pretty rusty using VBA but I think I have a pretty good start. The problem is on line 24. I have no idea how to copy the section to the new presentation. Is anyone familiar enough to steer me down the right path.
Sub Latin_Square()
Dim amountOfSubjects As Integer
'Declare the amount of subjects you have in your study
amountOfSubjects = 14
Dim filePath As String
filePath = "C:/1.pptx"
Dim amountofsections As Integer
Dim i As Integer
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim desktopPath As String
'find out where user's desktop is
desktopPath = Environ("UserProfile") & "\Desktop\"
Dim oldPresentation As Presentation
Dim newPresentation As Presentation
'open the target presentation
Set oldPresentation = Presentations.Open("C:\1.pptx")
For i = 1 To oldPresentation.Slides.Count
oldPresentation.Slides.Item(i).Copy
newPresentation.Item(1).Slides.Paste
Next i
oldPresentation.Close
With newPresentation
.SaveCopyAs _
FileName:=fso.BuildPath(desktopPath, "Test" & 1 & ".pptx"), _
FileFormat:=ppSaveAsOpenXMLPresentation
End With
End Sub
If you want to copy slides with their sections, then you can not paste the slide by newPresentation.Slides.Paste only, as that moves the section of the last slide to the newly pasted slide.
Here's an example how to copy slide-by-slide, check if a slide is the beginning of a section, and how to add a new section then:
Public Sub CopySlidesWithSections()
Dim oldPresentation As Presentation, newPresentation As Presentation
Dim oldSlide As Slide, newSlide As Slide
Dim oldSectionProperties As SectionProperties, newSectionProperties As SectionProperties
Dim i As Integer
Set oldPresentation = ActivePresentation
Set oldSectionProperties = oldPresentation.SectionProperties
Set newPresentation = Application.Presentations.Add
Set newSectionProperties = newPresentation.SectionProperties
For Each oldSlide In oldPresentation.Slides
oldSlide.Copy
' Would lead to wrong sectioning: Set newSlide = newPresentation.Slides.Paste.Item(1)
Set newSlide = newPresentation.Slides.Paste(newPresentation.Slides.Count + 1).Item(1)
For i = 1 To oldSectionProperties.Count
If oldSectionProperties.FirstSlide(i) = oldSlide.SlideIndex Then
newSectionProperties.AddBeforeSlide _
newSlide.SlideIndex, _
oldSectionProperties.Name(i)
Exit For
End If
Next i
Next oldSlide
End Sub
I'm trying to apply a template to a powerpoint through excel. The powerpoint template is embedded within my excel file via insert -> Object. I've successfully used the .applytemplate method to apply a template from file, but I cannot adjust the code to reference the embedded powerpoint template. I tried using OLEObject, but I'm afraid that isn't correct. Please review below code.
Sub ppCreate()
Dim myPP As PowerPoint.Application
Dim myPres As PowerPoint.Presentation
Dim activeSlide As PowerPoint.Slide
Dim ppObj As OLEObject
' Create instance of PowerPoint
Set myPP = CreateObject("Powerpoint.Application")
' For automation to work, PowerPoint must be visible
myPP.Visible = True
' Create a presentation
Set myPres = myPP.Presentations.Add
' Set slide view to Slide Only
myPP.ActiveWindow.ViewType = ppViewSlide
'Resize to 4:3
myPres.PageSetup.SlideSize = 2
'Add a slide
Set activeSlide = myPres.Slides.Add(1, ppLayoutBlank)
'Import Template
Worksheets("CBRDATA").Select
Set ppObj = ActiveSheet.OLEObjects("ppObj") 'NOT WORKING
myPres.ApplyTemplate (ppObj) 'NOT WORKING
myPres.ApplyTemplate "C:\CBR_TEMPLATE_COVER.potx" 'WORKING
Worksheets("CBR").Select
End Sub
Update:
'Test if template exists in C:\
If Dir("C:\CBR_TEMPLATE_COVER.potx") = "" Then
'Open/Save the embedded template to C:\
Set tempPP = CreateObject("Powerpoint.Application")
Worksheets("CBRDATA").OLEObjects("ppObj").Verb 0
tempPP.Visible = True
Set tempPres = tempPP.ActivePresentation
tempPres.SaveCopyAs ("C:\CBR_TEMPLATE_COVER.potx")
tempPres.Close
Else:
End If
' Create instance of PowerPoint
Set myPP = CreateObject("Powerpoint.Application")
This doesn't work because ActiveSheet.OLEObjects("ppObj") is type OLEObject, not PowerPoint.Presentation.
Set ppObj = ActiveSheet.OLEObjects("ppObj") 'NOT WORKING
While manually double-clicking on the object open the POTX file (actually it opens a new blank PPTX using the POTX as template), your assignment statement above isn't doing any of that, it's trying instead to put an OLEObject where a Presentation is expected, and that will always fail.
So, how to "open" the OLEObject? OLEObject has a .Verb method, and the following will perform the object's default action, which in the case of embedded package objects, is usally to "open" them.
The Solution
'Import Template
'## This should Open the template
Worksheets("CBRDATA").OLEObjects("ppObj").Verb 0
'## Assign the ActivePresentation to your ppObj variable
Set ppObj = myPP.ActivePresentation
Editorializing: Embedded OLEObjects are notoriously problematic, and probably not an ideal place to story things like document templates :)
I am attempting to store xml metadata within chart shapes in a PowerPoint presentation.
I need to ensure that the shape only contains the current xml data, so I have a function to delete existing data (if any) and add the current data.
Sub Test()
Dim cht as Chart
Dim xml as String
Set cht = ActivePresentation.Slides(1).Shapes(1)
xml = "<Chart property1='true' property2='false'>blah blah blah</Chart>"
EmbedChartXML xml, cht
End Sub
Sub EmbedChartXML(xml As String, cht As Shape)
Dim x As Variant
'Get rid of any previous data
For Each x In cht.CustomerData
x.Delete
Next
Set xmlPart = cht.CustomerData.Add
xmlPart.LoadXML xml
End Sub
The For Each loop is failing with the indicated error message. I can see that the cht.CustomerData.Count = 2 (for example), but if I try to view this in the Locals window, I get the same error.
UPDATE
Here is another test routine that is failing, even though there is nothing inside the For/Next loop.
Sub TestIteration()
Dim sld As Slide
Dim pres As Presentation
Dim shp As Shape
Dim x As CustomXMLPart
Set pres = ActivePresentation
Set sld = pres.Slides(2)
For Each shp In sld.Shapes
Set pptCustomerData = shp.CustomerData
For Each x In shp.CustomerData
' For Each pptCustomXMLPart In pptCustomerData
' Debug.Print pptCustomXMLPart.Id
' Next
Next
Next
End Sub
Others here cannot replicate this error in Excel 2013 (I am using Excel 2010) where the collection object itself becomes inaccessible. Perhaps there is a bug or something, but I could not find much on Google about similar errors...
I ultimately arrive at this solution. I am not sure why the CustomXMLPart's .Delete method doesn't actually delete the item from the collection (instead it makes it to Nothing, and then failure on successive iteration attempts).
Instead, I use the CustomerData.Delete method. This seems to be working as expected.
Sub EmbedChartXML(xml As String, cht As Shape)
Dim x As Variant
Dim cData As CustomerData
Dim xID As String
Set cData = cht.CustomerData
Debug.Print cht.CustomerData.Count
'Get rid of any previous data
For Each x In cData
xID = x.Id
cData.Delete xID
Next
With cData.Add
.LoadXML xml
End With
Debug.Print cht.CustomerData.Count
End Sub