I work from excel, and i open several powerpoint in a loop inside a directory, in vba.
While i run the macro (from excel), I make a loop within every shape inside every slides in powerpoints presentation.
I stop the macro to see if AutoShapeType = -2, and i select it in vba just to check visualy if the shape is the right shape i want.
Otherwise, if the selected shape doesn't seems right, I select it manually and I want to know how the syntaxe to get the id of the current selected shape, in order to name it.
Set PPtapp = CreateObject("Powerpoint.Application")
PPtapp.Visible = True
Dim sld As Slide
Dim numslide As Long
Dim nbslide As Long
Dim WVL_CptShape As Integer
'list of every powerpoint path
ppt = ThisWorkbook.Worksheets("Template").Range("A" & i).Value
For i = 2 To ThisWorkbook.Worksheets("Template").Range("A65536").End(xlUp).Row + 1
Set PptDoc = PPtapp.Presentations.Open(ppt)
With PptDoc
For Each sld In PptDoc.Slides
For WVL_CptShape = 1 To .Slides(sld.SlideNumber).Shapes.Count
WVL_Id = .Slides(sld.SlideNumber).Shapes(WVL_CptShape).ID
If PptDoc.Slides(sld.SlideNumber).Shapes(WVL_CptShape).AutoShapeType = -2 Then
'I select the shape to see visualy if it's a good selection and I stop the macro
PptDoc.Slides(sld.SlideNumber).Shapes(WVL_CptShape).Select
Stop
'if the selection doesnt seems right I select the right shape manualy
'Question : in vba, i want to change the name of the selected shape.
'But i don't know how to get the id of the current selected shape (see below : ID_OF_CURRENT_SHAPE_SELECTED_MANUALY)
'I would like to rename it, in order to recognize it easily next time
PptDoc.Slides(sld.SlideNumber). Shapes(ID_OF_CURRENT_SHAPE_SELECTED_MANUALY).Selection.Name = "Myshape"
end if
Next WVL_CptShapeNext
sld.Close
End With
Next
PPtapp.Quit
Set PPtapp = Nothing
Set PptDoc = PPtapp.Presentations.Open(ppt)
With PptDoc
For Each sld In PptDoc.Slides
For WVL_CptShape = 1 To sld.Shapes.Count
WVL_Id = sld.Shapes(WVL_CptShape).ID
If sld.Shapes(WVL_CptShape).AutoShapeType = -2 Then
'I select the shape to see visualy if it's a good selection and I stop the macro
sld.Shapes(WVL_CptShape).Select
Stop
' And to change the name of the shape:
sld.Shapes(WVL_CptShape).Name = "New name for shape"
' or better, in case you selected a different shape:
ActiveWindow.Selection.ShapeRange(1).Name = "New name for shape"
In this type of situation, you want to work with the shape's Index, not its ID.
Note that you can iterate through the shapes collection on a slide just as you can iterate through the slides collection in a presentation. It makes the code a lot simpler to write and to follow:
Set PptDoc = PPtapp.Presentations.Open(ppt)
With PptDoc
For Each sld In PptDoc.Slides
For each shp in sld.shapes
If shp.AutoShapeType = -2 Then
'I select the shape to see visualy if it's a good selection and I stop the macro
shp.Select
Stop
Related
I need a reference to a selected (via mouse click, it only needs to be one selection) shape in Visio. However the shape might be in a group.
I cant seem to get it to work when I select a shape in a group, the shp Object remains empty.
Sub selectTest()
Dim sel As Visio.Selection
Set sel = ActiveWindow.Selection
Dim shp As Visio.Shape
Set shp = sel.PrimaryItem
If Not shp Is Nothing Then
MsgBox "It worked"
Else
MsgBox "No shape in sel"
End If
End Sub
When the "Top-Level" Group is selected, it works.
When a shape inside the group, which might as well be a group itself, is selected, it doesn't.
When a shape which is not in a group is selected, it works again.
Context: I want to fire custom VBA code from the context menu. When you right click the shape, it is selected automatically.
How can I get a reference to a shape when it is in a group?
EDIT: To clarify further: Shapes inside my Document all have corresponding database entries. I want to (via XML) add a custom Delete button to the context menu (that works), this should call a deletemethod that gets the shape on which the method was called as a parameter so it can search for the corresponding DB entry and delete that (as well as the entries of any subshapes if the selected shape is a group) before the shape (and all of its subshapes) is deleted with shape.delete
Use Selection.IterationMode property to include sub-selected shapes in the selection
Set sel = ActiveWindow.Selection
sel.IterationMode = 0
Set shp = sel.PrimaryItem
I don't know Visio VBA, but give it a try:
UPDATE
Sub selectTest()
Dim x As Integer
Dim sel As Visio.Selection
Dim shp As Visio.Shape
Dim inner_shape As Visio.Shape
Set sel = ActiveWindow.Selection
Set shp = sel.PrimaryItem
For x = 1 To shp.Shapes.Count
Set inner_shape = shp.Shapes(x)
'// Do something with inner shape
Next
End Sub
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.
My intention is to open an existing PowerPoint presentation along with an existing Excel workbook, and subsequently run a VBA macro from Excel which would update the corresponding values in PowerPoint.
For this I've identified the Shape name of the corresponding text boxes I want to update in PowerPoint by highlighting the specific textbox and used Format -> Align. Then I've created 3 columns in Excel with the values:
Slide index Shape name Value
1 Title 2 =CONCATENATE("REPORT ";YEAR(TODAY()))
1 Placeholder for date1 =TODAY()
I use the macro (which I unfortunately can't remember from which site I copied it):
Sub writedata()
Dim c As Object
Dim shapeslide
Dim shapename
Dim shapetext
Set ppapp = GetObject(, "Powerpoint.application")
Set pppres = ppapp.ActivePresentation
For Each c In Blad2.Range("a2:a" & Blad2.Range("a" & Rows.Count).End(xlUp).Row)
shapeslide = Blad2.Range("a" & c.Row)
shapename = Blad2.Range("b" & c.Row)
shapetext = Blad2.Range("c" & c.Row).Text
pppres.Slides(shapeslide).Shapes(shapename).TextEffect.Text = shapetext
Next
End Sub
My problem is that Slide 1 wont be updated at all in its corresponding Shape name. The only action which happens when I execute this macro is that, for some reason, Slide 3 has its font size modified to become size 35 instead of size 16. I can't understand why that is happening. The Shape name of the shape whose font size is altered is neither written into the Excel workbook, nor is it the same shape name as one of those two written in Excel.
Hopefully someone can shed some light into this.
Lets get your slides and shapes listed by excel to ensure that they are what you expect. Sometimes they are really oddly named/IDed. Since you have slides not changing that should and slides changing that should not... we definitely need to doublecheck these. This will itterate through each slide and each shape on that slide and list the slide ID and Name and each shape ID and Name. I have a presentation and the first slide is slide 297 for some reason. Then slide 250 is second. Slide 50 is 3rd. The rest are all numbered oddly also. o.O
Turn on your immediates window to see the debug text.
Sub SlidesShapes()
Dim i As Integer, j As Integer
Set ppapp = GetObject(, "PowerPoint.Application")
Set ppres = ppapp.ActivePresentation
For i = 1 To ppres.Slides.Count'slides and shapes start counting at 1 not 0
Debug.Print ppres.Slides(i).SlideID
Debug.Print ppres.Slides(i).Name
For j = 1 To ppres.Slides(i).Shapes.Count
Debug.Print ppres.Slides(i).Shapes(j).ID
Debug.Print ppres.Slides(i).Shapes(j).Name
Next
Next
End Sub
Also, when you step through your original code (not this snippet) what do you see in your locals window for each step? Anything weird going on there that jumps out at you? Any variables populated with something unexpected or not completely right?
I have a PowerPoint slide with different images. I need to create VBA code in PowerPoint that recognises all these images and fades them out one by one - except for one randomly chosen image. This last image should remain until the end, then fade out and display in the middle of the slide.
I have an idea of how to do it and have experience with object oriented languages (R) but I have never used VBA before. Therefore I would be grateful for pointers on how to do any of the following in VBA:
Determine number of images on active slide
Select each image one after another and assign a counter variable as selection label (that part should work as described here)
Create "Range A" of all assigned counter variables
Select random number "x" in "Range A"
Create "Range B" of all counter variables in "Range A" EXCEPT for the random number "x"
Randomise the order of variables in "Range B"
Loop through "Range B" and fade out images whose label corresponds to the respective "Range B" variable that comes up
Fade out the image whose label corresponds to "x"
Insert the image whose label corresponds to "x" in the centre of the slide
If it is very difficult to recognise images or assign labels to those images I can also do so manually. However, it would be nicer if that could happen automatically. I would be grateful for any pointers, also in the form of links if you think that part of the above process is already described somewhere else (I'm afraid since I'm inexperienced in VBA I am not using very effective search terms).
EDIT:
Please find the solution (steps 8 and 9 are still missing)
Sub SelectionMacro()
Dim oSl As Slide
Dim oSh As Shape
Dim aArrayOfShapes() As Variant
Dim ShapeX As Shape
Dim N As Long
Dim Temp As Variant
Dim J As Long
Dim FadeEffect As Effect
Set oSl = ActivePresentation.SlideS(1)
'This section creates an array of all pictures on Slide1 called
'"aArrayOfShapes"
For Each oSh In oSl.Shapes
If oSh.Type = msoPicture Then
On Error Resume Next
Debug.Print UBound(aArrayOfShapes)
If Err.Number = 0 Then
ReDim Preserve aArrayOfShapes(1 To UBound(aArrayOfShapes) + 1)
Else
ReDim Preserve aArrayOfShapes(1 To 1)
End If
Set aArrayOfShapes(UBound(aArrayOfShapes)) = oSh
End If
Next
'This section creates a random index number within the bounds of the
'length of aArrayOfShapes and assigns the shape with that index number
'to the Shape object ShapeX
Randomize
NumberX = Int((UBound(aArrayOfShapes) - (LBound(aArrayOfShapes) - 1)) * Rnd) + LBound(aArrayOfShapes)
Set ShapeX = aArrayOfShapes(NumberX)
'This section shuffles aArrayOfShapes
For N = LBound(aArrayOfShapes) To UBound(aArrayOfShapes)
J = CLng(((UBound(aArrayOfShapes) - N) * Rnd) + N)
If N <> J Then
Set Temp = aArrayOfShapes(N)
Set aArrayOfShapes(N) = aArrayOfShapes(J)
Set aArrayOfShapes(J) = Temp
End If
Next N
'This section loops through all Shapes in aArrayOfShapes and
'fades them out one by one EXCEPT for ShapeX
For Each Shape In aArrayOfShapes
If ShapeX.Name <> Shape.Name Then
Set FadeEffect = oSl.TimeLine.MainSequence.AddEffect _
(Shape:=Shape, effectid:=msoAnimEffectFade, trigger:=msoAnimTriggerAfterPrevious)
With FadeEffect
.Timing.Duration = 0.5
.Exit = msoTrue
End With
End If
Next Shape
End Sub
In order to reset the slide to the state before running the macro (so as to be able to run it again and display another random image) the following macro needs to be run:
Sub ResetSelection()
For i = ActivePresentation.SlideS(1).TimeLine.MainSequence.Count To 1 Step -1
ActivePresentation.SlideS(1).TimeLine.MainSequence(i).Delete
Next i
End Sub
Working out the range of images shouldn't be too hard. This'll get you started.
Assigning animation to shapes can be tricky. You might be better off duplicating the slide with all the images then deleting all but a randomly chosen image.
Dim oSl As Slide
Dim oSh As Shape
' Dynamic array of shapes to hold shape references
Dim aArrayOfShapes() As Shape
Set oSl = ActiveWindow.Selection.SlideRange(1)
For Each oSh In oSl.Shapes
If oSh.Type = msoPicture Then
On Error Resume Next
Debug.Print UBound(aArrayOfShapes)
If Err.Number = 0 Then
ReDim Preserve aArrayOfShapes(1 To UBound(aArrayOfShapes))
Else
ReDim Preserve aArrayOfShapes(1 To 1)
End If
Set aArrayOfShapes(UBound(aArrayOfShapes)) = oSh
End If
Next`enter code here`
' Now you have an array containing references to all the pictures
' on the slide. You can use a random number function to return
' an index into the array to choose a picture at random.
With aArrayOfShapes(RandomNumberFunction(LBound(aArrayOfShapes), UBound(aArrayOfShapes)))
' google to find an appropriate function; they're out there
' do whatever you need to do with your shapes here
End With
I have a library of eight images on my PowerPoint slide. Based on a userform input, some of the components get duplicated and renamed by adding a "1" or "2" after the original image's name so that they are differentiable. I then want to group the new images (I am building up an item from the component images). I am able to duplicate the images and line them up correctly, but I am having trouble grouping them. Note that I am not always grouping the same number of items, it is dependent on user inputs.
I receive the error "Shape (unknown member): Invalid request. To select a shape, its view must be active."
I searched and attempted to implement several strategies from the help forums but am coming up empty.
PLEASE HELP!!!
-Kevin
Part of code below because it is very long, but this is where my first problem arises:
Dim Cargo As Shape, Cargo_Dup as Shape, Chemical as Shape, Chemical_Dup as Shape
Set Cargo = ActivePresentation.Slides(2).Shapes("Cargo")
Set Chemical = ActivePresentation.Slides(2).Shapes("Chemical")
Cargo.Name = "Cargo"
Chemical.Name = "Chemical"
With ActivePresentation
Set Cargo_Dup = ActivePresentation.Slides(2).Shapes("Cargo")
With Cargo_Dup.Duplicate
.Name = "Cargo_1st"
.Left = 0
.Top = 540
End With
'CHEMICAL
If Input1 = "Chemical" Then
Set Chemical_Dup = ActivePresentation.Slides(2).Shapes("Chemical")
With Chemical_Dup.Duplicate
.Name = "Chemical" & 1
.Left = 36.74352
.Top = 540 + 0.36
End With
'''''WHERE PROBLEM ARISES'''''
ActivePresentation.Slides(2).Shapes("Cargo_1st").Select
ActivePresentation.Slides(2).Shapes("Chemical1").Select msoFalse
Set Vehicle = ActiveWindow.Selection.ShapeRange.Group
Vehicle.Name = "Vehicle"
'Elseif with a bunch for options where addition grouping occurs
I need some kind of keyboard macro to type this for me:
Never select anything unless you absolutely have to.
You nearly never absolutely have to.
You're asking how to make a view active so that you can select something.
I figure that's the wrong question.
It's more useful to know how to work with shapes WITHOUT having to select them.
Grouping shapes w/o selecting them is a bit tricky, but it can be done.
Here's an example of how you might go about this:
Sub GroupWithoutSelecting()
Dim oSl As Slide
Dim oSh As Shape
Dim aShapes() As String
Set oSl = ActivePresentation.Slides(2) ' or whichever slide you like
ReDim aShapes(1 To 1)
With oSl
For Each oSh In .Shapes
If oSh.Type <> msoPlaceholder Then ' can't group placeholders
' Substitute the real condition you want to use
' for selecting shapes to be grouped here
If oSh.Type = msoAutoShape Then
' add it to the array
aShapes(UBound(aShapes)) = oSh.Name
ReDim Preserve aShapes(1 To UBound(aShapes) + 1)
End If
End If
Next
' eliminate the last (empty) element in the array
ReDim Preserve aShapes(1 To UBound(aShapes) - 1)
' Create a shaperange from the array members and group the shaperange
.Shapes.Range(aShapes).Group
End With ' oSl
End Sub