I want to save Slides 1 to Slide 20 (of 450 slides) as a new presentation.
New presentation name should be XYZ.pptx.
I tried:
Sub ExportSlides()
Dim myPresentation As Presentations
Set myPresentation = Presentations("PPTWITH450SLIDES.pptx").Slides.range(Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20))
myPresentation.Export ("C:\Users\rajat.kapoor\Droom Overview.pptx",FilterName:="pptx")
End Sub
It is giving:
Syntax Error
in the last line
myPresentation.Export ("C:\Users\rajat.kapoor\Droom Overview.pptx",FilterName:="pptx")
It's usually simpler to delete unwanted slides from a saved copy of your original presentation. Like so:
Option Explicit
Sub ExportSlides()
Dim x As Long
' Presentation not PresentationS
Dim myPresentation As Presentation
' If the presentation is already open:
' Set myPresentation = Presentations("exportable.pptx")
' otherwise
Set myPresentation = Presentations.Open("c:\temp\exportable.pptx")
myPresentation.SaveAs ("c:\temp\exported.pptx")
' The current presentation is now Exported.pptx
With myPresentation
' change 5 to the highest number slide you want to include + 1
For x = .Slides.Count To 6 Step -1
.Slides(x).Delete
Next
End With
myPresentation.Save
End Sub
You get the syntax error because you need to remove the parenthesis from
myPresentation.Export ("C:\Users\rajat.kapoor\Droom Overview.pptx",FilterName:="pptx")
As the official documentation describes the Presentation.Export method has no return value. Therfore it is not a function and has no parentesis for the parameters:
myPresentation.Export "C:\Users\rajat.kapoor\Droom Overview.pptx", FilterName:="pptx"
Alternatively you can use the Call statement (with parenthesis):
Call myPresentation.Export("C:\Users\rajat.kapoor\Droom Overview.pptx", FilterName:="pptx")
For further explanation also see: https://stackoverflow.com/a/56579194/3219613
To do what you want it is easier to copy the entire presentation and delete the unnecessary slides as #SteveRindsberg suggested in his answer. The Export method is better used for exporting slides into images.
Related
In my tool I am trying to create a shape, rename it, have it move with the shifting widths of columns, and hyperlink it to a summary sheet. This is what I have so far, thanks in advance.
For s = 7 To Sheets.Count
With Sheets(s)
Dim GoToSummary As Shape
Set GoToSummary = .Shapes.AddShape(msoShapeRoundedRectangle, 400, 153 + 12.75 * 2, 300, 50)
.Shapes(GoToSummary).TextFrame.Characters.Text = "Go Back To Summary"
End With
Next s
I know this is not correct, that is why I am reaching out, because I couldn't find anything similar to my situation.
You were pretty close!
Sub test()
Dim GoToSummary As Shape
For s = 7 To Sheets.Count
Set GoToSummary = Sheets(s).Shapes.AddShape(msoShapeRoundedRectangle, 400, 153 + 12.75 * 2, 300, 50)
GoToSummary.TextFrame.Characters.Text = "Go Back To Summary"
Sheets(s).Hyperlinks.Add Anchor:=GoToSummary, Address:="", SubAddress:="Summary!A1"
Next s
End Sub
Dim GoToSummary outside of the loop
Once you've defined GoToSummary with Set, you can just refer to it directly, i.e. as GoToSummary instead of .Shapes(GoToSummary)
Added the hyperlink as well
Code that perfectly works in earlier versions of PPT stopped working in 2016.
When I try to change the left property of a shape in a chart, I get a Method left of object shape failed error.
I can perfectly read the .Left property.
I am running out of ideas? What can I do?
Sub test11()
Dim sld As Slide
Dim objChart As Object
Dim shpBubble As Object
Set sld = ActivePresentation.Slides("ScatterPlot01_Purch6")
Set objChart = sld.Shapes("Chart01").Chart
sld.Select
objChart.Select
Set shpBubble = objChart.Shapes("P01")
'shpBubble.Select
Debug.Print shpBubble.Left, shpBubble.Visible
shpBubble.Left = 10
End Sub
UPDATE
Having tested in PowerPoint 2010 and 2013, where it works, this now looks like a bug in 2016!
* END *
I managed to recreate the error in PowerPoint 2016 (PC) by manually adding a shape to a test chart (select the chart then click Format / Insert Shapes) and trying to write to several of it's properties including position and formatting such as changing fill colour. All generate an error.
Maybe one workaround is to use the .Delete method to delete the desired shape and then add a new shape at the required size and position. Something like this:
Sub test11()
Dim sld As Slide
Dim objChart As Chart 'Object
Dim shpBubble As Shape 'Object
Set sld = ActivePresentation.Slides("ScatterPlot01_Purch6")
Set objChart = sld.Shapes("Chart01").Chart
sld.Select
objChart.Select ' this won't work as you can only select the parent shape sld.Shapes("Chart01")
With objChart
.Shapes("P01").Delete
.Shapes.AddShape msoShapeOval, 10, 10, 20, 20
End With
End Sub
The challenge is that because the new shape is added as read only, the formatting can't be set!
I need to be able to create a new .ppt (PowerPoint presentation) from selected slides in my original .ppt. The following macro will take whatever slides you currently have selected and copy them into a new .ppt. I've found the following nice code to do most of the work.
Private Sub NytPPT_Click()
'PURPOSE: Copies selected slides and pastes them into a brand new presentation file
'SOURCE: www.TheSpreadsheetGuru.com
Dim NewPPT As Presentation
Dim OldPPT As Presentation
Dim Selected_slds As SlideRange
Dim Old_sld As Slide
Dim New_sld As Slide
Dim x As Long, y As Long
Dim myArray() As Long
Dim SortTest As Boolean
'Set variable to Active Presentation
Set OldPPT = ActivePresentation
'Set variable equal to only selected slides in Active Presentation
Set Selected_slds = ActiveWindow.Selection.SlideRange
'Sort Selected slides via SlideIndex
'Fill an array with SlideIndex numbers
ReDim myArray(1 To Selected_slds.Count)
For y = LBound(myArray) To UBound(myArray)
myArray(y) = Selected_slds(y).SlideIndex
Next y
'Sort SlideIndex array
Do
SortTest = False
For y = LBound(myArray) To UBound(myArray) - 1
If myArray(y) > myArray(y + 1) Then
Swap = myArray(y)
myArray(y) = myArray(y + 1)
myArray(y + 1) = Swap
SortTest = True
End If
Next y
Loop Until Not SortTest
'Set variable equal to only selected slides in Active Presentation (in numerical order)
Set Selected_slds = OldPPT.Slides.Range(myArray)
'Create a brand new PowerPoint presentation
Set NewPPT = Presentations.Add
'Align Page Setup
NewPPT.PageSetup.SlideHeight = OldPPT.PageSetup.SlideHeight
NewPPT.PageSetup.SlideOrientation = OldPPT.PageSetup.SlideOrientation
NewPPT.PageSetup.SlideSize = OldPPT.PageSetup.SlideSize
NewPPT.PageSetup.SlideWidth = OldPPT.PageSetup.SlideWidth
'Loop through slides in SlideRange
For x = 1 To Selected_slds.Count
'Set variable to a specific slide
Set Old_sld = Selected_slds(x)
'Copy Old Slide
yy = Old_sld.SlideIndex
Old_sld.Copy
'Paste Slide in new PowerPoint
NewPPT.Slides.Paste
Set New_sld = Application.ActiveWindow.View.Slide
'Bring over slides design
New_sld.Design = Old_sld.Design
'Bring over slides custom color formatting
New_sld.ColorScheme = Old_sld.ColorScheme
'Bring over whether or not slide follows Master Slide Layout (True/False)
New_sld.FollowMasterBackground = Old_sld.FollowMasterBackground
Next x
End Sub
What I need to do, is to select which slides to copy - based on check boxes. So, for example if I select Check Box 1 = TRUE, it will create slides 1, 2 and 3. Or if I select Check box 2 = TRUE, that it could select slide 3, 4, 5 and 6. And so, if I selected both boxes it would create slides = 1, 2, 3, 4, 5, 6. Leaving out any duplicates.
I've tried a lot, including this:
Private Sub CheckBox1_Click()
If CheckBox1.Value = True Then
ActivePresentation.Slides.Range(Array(1, 2, 3)).Select
Else
MsgBox "nothing"
End If
End Sub
Private Sub CheckBox2_Click()
If CheckBox2.Value = True Then
ActivePresentation.Slides.Range(Array(3, 4, 5, 6)).Select
Else
MsgBox "nothing"
End If
End Sub
I get the error: Slide (unknown member) : Invalid request. This view does not support selection.
I am not sure how I could get this to work? Any help is appreciated, I'am very new to VBA coding.
All credit for code goes to. http://www.thespreadsheetguru.com/the-code-vault/2014/4/3/copy-selected-slides-into-new-powerpoint-presentation
You can switch the view to enabled the slides to be selected as follows:
ActiveWindow.ViewType = ppViewSlideSorter
For some reason, the slides aren't selected in the normal view!
But selecting things in PowerPoint brings its own challenges (as seen with the view type) and you don't need to select them in order to copy and paste them as per this example:
With ActivePresentation.Slides
.Range(Array(1, 2)).Copy
.Paste
End With
This will simplify your code as you don't need to manage windows and their views.
I'm working in Excel 2013 to (programmatically) add a straight line connector between the lower right hand corner of a rectangle that is part of a grouped shape with the endpoint of a grouped series of line segments. As it stands, I can't even seem to do this manually on the Excel worksheet that contains these shapes.
Problems include:
Only midpoints on the desired rectangle will accept the connector.
The grouped series of line segments don't even show a "connection point" for the terminating end of the straight line connector.
Here's a graphic of what I'm trying to do:
[I don't have 10 "reputation points" so I can't seem to post a picture of what I'm trying to do. Not an especially helpful feature! How do I get reputation points in this game?]
I've been able to create and name the two groups and thought it would be a cinch to work with them to add a connector, but that has not been the case.
Here's the code I've been working with:
Sub create_new_profile()
Dim firstRect As Shape
Dim firstLine As Shape
Set myDocument = Worksheets(1)
Set s = myDocument.Shapes
' Set firstRect = s.Range("shpNewGarage")
' Set firstLine = s.Range("shpProfile")
Dim Shp As Shape
' For Each Shp In myDocument.Shapes
For Each Shp In s
If Shp.Name = "shpNewGarage" Then
Set firstRect = Shp
Else
End If
Next Shp
' For Each Shp In myDocument.Shapes
For Each Shp In s
If Shp.Name = "shpProfile" Then
Set firstLine = Shp
Else
End If
Next Shp
firstRect.Select 'this works
firstLine.Select 'this works
' Set firstRect = s.AddShape(msoShapeRectangle, 100, 50, 200, 100)
' Set firstLine = s.AddShape(msoShapeRectangle, 300, 300, 200, 100)
' Set firstRect = ActiveSheet.Shapes.Range("shpNewGarage")
' Set firstLine = ActiveSheet.Shapes.Range("shpProfile")
Dim c As Shape
Set c = s.AddConnector(msoConnectorStraight, 0, 0, 100, 100)
' On Error Resume Next
With c.ConnectorFormat
**.BeginConnect ConnectedShape:=firstRect, ConnectionSite:=1**
.EndConnect ConnectedShape:=firstLine, ConnectionSite:=1
' .BeginConnect ConnectedShape:="shpNewGarage", ConnectionSite:=1
' .EndConnect ConnectedShape:="shpProfile", ConnectionSite:=1
' .BeginConnect ConnectedShape:=ActiveSheet.Shapes.Range("shpNewGarage"), ConnectionSite:=1
' .EndConnect ConnectedShape:=ActiveSheet.Shapes.Range("shpProfile"), ConnectionSite:=1
c.RerouteConnections
End With
End Sub
This particular version of the code ends with a runtime error on the line immediately following the line:
With c.ConnectorFormat
Here's the error message:
[I don't have 10 "reputation points" so I can't seem to post a picture of the error message I'm getting. Again, how do I get reputation points?]
Any direction at all to help me accomplish this task programmatically would be greatly appreciated.
Thanks for explaining that I can now post images. That should help.
Here are the figures I'm working with:
The rectangle group (firstRect, "shpNewGarage") represents a new garage I plan to build between the existing one and the street. The profile group (firstLine, "shpProfile") represents the profile (side view/elevation) of the existing driveway (the light blue line.) The idea is to attach the new profile (red line) to the lower right corner of the new garage at one end and to the right end of the existing profile (curb) so that as I move the new garage up, down, right and left, the connector representing the new profile will remain attached to these points to show graphically the angle (grade) and length of the new driveway.
Here's the error message I receive when I run the code:
This looks like quite a hill to climb, as I am having problems even adding the connector to the desired points manually.
Thanks to all who have read/responded to my issue. Stackoverflow has been a great resource to me in the past, and this is the first time I've ever had to post my own fairly specific problem.
You explained everything very well, and the images you uploaded helped
What your code is doing seems to be correct, but the error is complaining about one of the parameters, and it could be the 2nd one:
.BeginConnect ConnectedShape:=firstRect, ConnectionSite:=1
ConnectionSite: "A connection site on the shape specified by ConnectedShape. Must be an integer between 1 and the integer returned by the ConnectionSiteCount property of the specified shape"
I think your firstRect has a problem with the first Node: when you initially generate a rectangle it doesn't have connection points in the corners, and I'm not sure about the initial available nodes
A rectangle is a specific class of shape that must first be converted to a (generic) shape class: "You must apply the AddNodes method to a FreeformBuilder object at least once before you use the ConvertToShape method", in order to add connection points (nodes) to the corner
Another issue might be caused by groups. I'm not sure if you grouped the objects, but grouping may not allow direct access to connection points
As an exercise, I was able to draw lines between 2 rectangles the way you intended, but my lines are not actually connected to the shapes, so if I move one rectangle the lines will not move with it. Here is my code:
Option Explicit
Sub create_new_profile()
Dim ws As Worksheet
Dim shp1 As Shape
Dim shp2 As Shape
Dim line1 As Shape
Dim line2 As Shape
Set ws = Sheet1
With ws.Shapes
'AddShape: Left=10, Top=10, Width=50, Height=30
Set shp1 = .AddShape(msoShapeRectangle, 10, 10, 50, 30)
Set shp2 = .AddShape(msoShapeRectangle, 70, 50, 50, 30)
'AddConnector: BeginX=60, BeginY=10, EndX=120, EndY=50
Set line1 = .AddConnector(msoConnectorStraight, 60, 10, 120, 50)
Set line2 = .AddConnector(msoConnectorStraight, 60, 40, 120, 80)
End With
line1.Line.ForeColor.RGB = RGB(255, 0, 0) 'Color Red
line2.Line.ForeColor.RGB = RGB(255, 0, 0)
End Sub
and this is the end result:
.
If you need the lines to be linked to the rectangles, you'll have to convert the rectangles to shapes, then add corner connection points or nodes (msoEditingCorner), then add connector lines from one corner node of the first rectangle to the other corner node of the second rectangle
One of the ways to (manually) convert to shape, and record your actions to see the generated VBA code and objects used, is by right-clicking the shape and selecting "Edit Points":
Hope this helps a bit
I have a subroutine that will create a shape, but I have two problems with the code:
I must specify on which slide this shape will be created. This is a problem if I want to create the same shape on multiple slides simultaneously. How do I achieve that? what do I replace activepresentation.slides(x) with?
I want the shape to have a hyperlink to a specific slide. What is wrong with my code to achieve that? It gives me an error when I try to assign an action to the shape I have created.
Sub createshape()
Dim oshp As Shape
Dim osld As Slide
'old code
Set osld = ActivePresentation.Slides(1)
Set oshp = osld.Shapes.AddShape(msoShapeRectangle, 485, 15, 104, 60)
oshp.ActionSettings (ppMouseClick)
.Action = ppActionHyperlink
.Hyperlink.Address = SlideNumber
.Hyperlink.SubAddress = 1 'this should take the hyperlink to slide 1 i hope.
End Sub
I want to automate this function because I will be doing this same thing for many many slides multiple times.
Something like this will act on the current slide. I tested for a slide 2 hyperlink to esnure that the code worked (and didn't use 1 as default)
Sub CreateShape()
Dim oShp As Shape
Dim oSld As Slide
Set oSld = ActivePresentation.Slides(ActiveWindow.Selection.SlideRange.SlideIndex)
Set oShp = oSld.Shapes.AddShape(msoShapeRectangle, 485, 15, 104, 60)
With oShp.ActionSettings(ppMouseClick)
.Action = ppActionHyperlink
'.Hyperlink.Address = SlideNumber
.Hyperlink.SubAddress = 2
End With
End Sub