I have this PPT vba script to delete all shapes in a region at the bottom left corner of each slide. It works but sometimes it leaves one shape in the area. If I run it again it will get rid of it, but I don't want to have to run it twice! How can I fix this?
Sub GoAwayDumbText()
Dim oPres As Presentation
Dim oSlides As Slides
Dim oSld As Slide
Dim oShp As Shape
Dim PathSep As String
Dim sTempString As String
#If Mac Then
PathSep = ":"
#Else
PathSep = "\"
#End If
Set oPres = ActivePresentation
Set oSlides = oPres.Slides
For Each oSld In oSlides
For Each oShp In oSld.Shapes
If oShp.Left <= 135 And oShp.Top >= 260 Then
oShp.Delete
Else
End If
Next oShp
Next oSld
End Sub
When you're iterating through a collection (shapes, slides, whatever) and deleting items along the way, For/Each loops won't behave as expected.
Instead, use (in this case)
For x = oSld.Shapes.Count to 1 Step -1
Delete from the end of the collection to the beginning rather than from the beginning to the end.
Why?
Suppose you have three items in the collection:
VBA starts with its internal For/Each counter set to 1
First item meets your criteria, you delete it
VBA increments its internal For/Each counter to 2
Since you deleted one item, there are only two items left in the collection, so VBA looks at the second item (which USED TO BE the third item) and deletes it.
VBA increments its internal counter to 3, but you've deleted the first two of three original items, so there's only 1 item in the collection; there's no item three so what used to be item 3 never gets looked at.
[If anyone can offer a better/clearer explanation of this, PLEASE have at it.]
Related
I am migrating a lot of old presentations to a new design using VBA. I have created the new file from a template, copied each slide across and applied the correct custom layout that I need to each one. Once done, I am left with a load of the old custom layouts that are not used, and want to delete them all. The new design uses 50 custom layouts. Is there a way to find the ones after that 50 and delete them? Or delete all layouts after a layout of a specific name?
Here is the code I'm using at the moment. This doesn't remove them all, for some reason. Any help is welcome.
Dim colUsedLayouts As New Collection
For Each sld In NewPres.Slides
colUsedLayouts.Add sld.CustomLayout
Next
Dim UsedLayout As CustomLayout
Dim LayoutHasBeenUsed As Boolean
Dim EndPointLogoFound As Boolean
For Each lay In NewPres.Designs(1).SlideMaster.CustomLayouts
If Trim(LCase(lay.name)) = "blank no logo" Then 'Used the else statement so it doesn't delete the Blank No logo layout
EndPointLogoFound = True
Else
If EndPointLogoFound Then
LayoutHasBeenUsed = False
For Each UsedLayout In colUsedLayouts
If UsedLayout Is lay Then
LayoutHasBeenUsed = True
End If
Next
If Not LayoutHasBeenUsed Then
lay.Delete
End If
End If
End If
Next
PowerPoint doesn't really track the order of slide layouts, so trying to delete layouts after a certain one isn't reliable. I would go by the layout name. Create a Select Case statement based on the layout name. In the first Case statement, place the names of all 50 good layouts. This Select Case statement will have no commands. Then create a Case Else statement that deletes any layout not found in in the first:
Select Case lay.name
Case "Title Slide", "Title and Content", "Comparison" 'etc. place all 50 names
'do nothing
Case Else
lay.Delete
End Select
When deleting things from a collection (slides, shapes, layouts, whatever), you need to step through the collection in reverse order otherwise you end up with this situation:
You delete the first one.
The second item in the collection is now item 1, so when you move to the second item and delete it, you're actually deleting what WAS item 3, leaving what WAS item 2 alone.
Instead:
For x = Collection.Count to 1 step -1
Collection(x).Delete
Next
In this case, you'd use Designs in place of Collection.
This macro deletes any unused custom layouts in a presentation, provided they are not set to "Preserved":
Sub RemoveUnusedCustomLayouts(newPres As Presentation)
On Error GoTo RemoveUnusedCustomLayouts_Error
Dim oLayout As CustomLayout
Dim tLayout As CustomLayout
Dim oSld As Slide
Dim delLayoutCnt As Integer
Dim delLayoutArray() As CustomLayout
Dim layoutUsed As Boolean
Dim i As Integer
delLayoutCnt = 0
' We're assuming the deck only has one slide master.
' This sub is only called by other subs that have already
' collapsed the deck into one slide master.
ReDim delLayoutArray(newPres.SlideMaster.CustomLayouts.Count)
For Each oLayout In newPres.SlideMaster.CustomLayouts
layoutUsed = False
If oLayout.Preserved = msoFalse Then
' Can't delete a layout if it's in use, so we check
' for that and add any unused, un-preserved layouts
' to Delete array.
For Each oSld In newPres.Slides
If oSld.CustomLayout.Name = oLayout.Name Then
layoutUsed = True
Exit For
End If
Next
If layoutUsed = False Then
delLayoutCnt = delLayoutCnt + 1
Set delLayoutArray(delLayoutCnt) = oLayout
End If
End If
Next
If delLayoutCnt > 0 Then
For i = 1 To delLayoutCnt
Set tLayout = delLayoutArray(i)
tLayout.Delete
Next
End If
On Error GoTo 0
Exit Sub
RemoveUnusedCustomLayouts_Error:
Debug.Print "Error " & Err.Number & " (" & Err.Description & ") in procedure RemoveUnusedCustomLayouts, line " & Erl & "."
End Sub
Every CustomLayout in a Design must have a unique name (this is why you'll often see "Title and Content_2" in a bloated deck), so checking against the CustomLayout name is the best way to get at the ones you want to delete.
I have a presentation to split into several smaller ones depending on the text in the header.
I've managed to find and compile a code that finds the last slide that has the text), then it selects several previous slides, copies them to a new presentation, saves it, and repeats that for the next value.
This would be fine if number of slides with every text was the same (and all the slides with the same text were in the same order), but it's not always the case in my presentation. I need to modify the function.
Basically, it should return not just a slide, but a slide range, and it should be resized with every loop where if function is true. I know how to get all the slide indexes as a string, but I don't know how to use that string to select those slides.
Function FindSlideByTitle(sTextToFind As String) As slide
For Each oSl In ActivePresentation.slides
With oSl.Shapes.Title.TextFrame
If .HasText Then
If InStr(1, .TextRange.Text, sTextToFind, vbTextCompare) > 0 Then
Set FindSlideByTitle = oSl
End If
End If
End With
Next
I don't see an advantage to creating a slide range in this instance. A function for this isn't going to work, since it can only return one slide at a time, as you've discovered.
Instead, create a Sub using your loop, then replace
Set FindSlideByTitle = oSl
with a routine to add the found slide to an array:
Option Base 1
Dim FoundSlide() As Integer
Dim oSl As Slide
Sub FindSlideByTitle()
ReDim Preserve FoundSlide(1)
For Each oSl In ActivePresentation.Slides
With oSl.Shapes.Title.TextFrame
If .HasText Then
If InStr(1, .TextRange.Text, "Ham", vbTextCompare) > 0 Then
Count% = UBound(FoundSlide)
ReDim Preserve FoundSlide(Count% + 1)
FoundSlide(Count% + 1) = oSl.SlideNumber
End If
End If
End With
Next
End Sub
Then process that subset of slides one at a time:
Sub DoSomethingWithSlide()
For X = 1 To UBound(FoundSlide)
With ActivePresentation.Slides(FoundSlide(X))
'Process each slide here
End With
Next X
End Sub
Anyway, this is what I came up with in the end, and it (almost) seems to be working.
Dim sSlides() As String
sSlides() = Split(FindSlide(sCountry), ";|;")
Dim n As Long
Dim iSlides() As Integer
ReDim iSlides(LBound(sSlides) To UBound(sSlides))
For n = LBound(sSlides) To UBound(sSlides)
iSlides(n) = CInt(sSlides(n))
Next n
Dim rCountrySlides As SlideRange
Set rCountrySlides = ActivePresentation.slides.range(iSlides)
rCountrySlides.Select
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 just started using VBA a few days ago. I noticed that some few commands do not seem to work on my computer and I was wondering whether this is due to my computer setup.
I am using VBA in PowerPoint 2013 on Windows 7 run via VMware Fusion (virtual machine) on MacOSX. I need to create a dynamic reference to the active slide, but several way of doing so broke my code:
Set oSl = Application.ActiveWindow.View.Slide
(as suggested here)
Set oSl = ActivePresentation.Slides(ActiveWindow.View.Slide.SlideNumber)
(as suggested here)
Set oSl = ActiveWindow.Selection.SlideRange.SlideIndex
(as suggested here)
None of these worked for me. Since I just started using VBA I simply inserted Message Boxes after different parts of the code, and looked at when the boxes where no longer triggered - in this case always after the "oSl =" line that I replaced with the various other approaches delineated above. Additionally,
Set oSl = ActiveWindow.Selection.SlideRange(1)
also broke my code (as discussed here)
What DID work so far was
Set oSl = ActivePresentation.SlideS(1)
All the methods above that didn't work (but should) contain "ActiveWindow". It would be great if you could advise on whether there are errors in my approach to selecting the active slide or whether the issue might be that VBA can't access the "ActiveWindow" properly because my PowerPoint runs on a virtual machine. Should that be the case, is there another way to select the currently active slide without using ActiveWindow?
EDIT: I am trying to apply this to the following code in PowerPoint. Basically what I want to do is replace the line "oSl = ActivePresentation.SlideS(1)" with a line of code that won't always target slide 1 but whichever slide is currently active. My question is not so much HOW to do this - there are plenty of instructions on how to do it online. My question is WHY these approaches are not working for me.
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
I had similar problem.
Try to replace:
ActiveWindow.View.Slide.SlideNumber
with:
ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
It was what I needed in my project, maybe it helps you.
As far as I know, the code below gets a shape from the active window, nudges it a bit, copies the slide and pastes it right after the current one, then turns the pasted slide into an active window, and nudges it again:
Sub Test()
' Get the active presentation
Dim oPresentation As Presentation
Set oPresentation = ActivePresentation
' Get the first slide in the presentation
Dim oSlide As Slide
Set oSlide = oPresentation.Slides(1)
' Get the first shape on the slide
Dim oShape As Shape
Set oShape = oSlide.Shapes(1)
' Nudge the shape to the right
oShape.Left = oShape.Left + 1
' Copy the whole slide
oSlide.Copy
' Paste the slide as a new slide at position 2
Dim oNewSlides As SlideRange
Set oNewSlides = oPresentation.Slides.Paste(2)
' Get a reference to the slide we pasted
Dim oNewSlide As Slide
Set oNewSlide = oNewSlides(1)
' Get the first shape on the NEW slide
Dim oNewShape As Shape
Set oNewShape = oNewSlide.Shapes(1)
' Nudge the shape to the right
oNewShape.Left = oNewShape.Left + 1
End Sub
As far as I can understand, in order to implement this code, I should have an active window opened and it should have at least one shape in it. Before I run this code I have only one slide; after the code has been run, I have two slides: the older one is number 1, and the newer one is number 2.
If I run this code one more time, I will get three slides as a result: the oldest one being still number 1, but the oldest one being number 2, not number 3.
My question is how can I make it produce slides, so that the newer slides are always the ones with a greater ordinal number, i.e. every newly created slide should be the last one in the slide preview sidebar (the lowest one)?
And also, how can I make it into a loop? So that I don't need to re-run this code again and again, but simply make a loop with a given number of loop's iterations.
I guess, if it should be a loop, then slides index should be turned into a variable, but I don't know how to do it in PowerPoint VBA.
I'm not sure your code makes any sense. It essentially:
Gets the 1st slide
Gets the 1st shape on the slide
Moves it 1 unit to the right
Copies the 1st slide
Pastes it in as the 2nd slide
Gets the 1st shape on the new 2nd
slide
Moves it 1 unit to the right
Why is it moving it twice, once on the original and once on the copy?
Regardless to answer your specific questions:
To paste it as the last slide, replace
Set oNewSlides = oPresentation.Slides.Paste(2)
With
Set oNewSlides = oPresentation.Slides.Paste() #no index pastes as last
To loop use something like this:
Dim oPresentation As Presentation
Set oPresentation = ActivePresentation
Dim oSlide As Slide
Dim oSlides As SlideRange
Dim oShape As Shape
Dim slideNumber As Integer
For slideNumber = 1 To 10
Set oSlide = oPresentation.Slides(oPresentation.Slides.Count)
oSlide.Copy
Set oNewSlides = oPresentation.Slides.Paste()
Set oSlide = oNewSlides(1)
Set oShape = oSlide.Shapes(1)
oShape.Left = oShape.Left + 5
Next slideNumber
This takes the last slide, copies it, pastes the copy as the new last one, nudges the first shape to the right, takes new last slide, copies it, pastes the copy as the last one, nudges the first shape to the right, etc.... It'll do this 10 times.