Powerpoint VBA Loop not looping through all slides - vba

Bit of an issue, I have some VBA code that loops through all of the sheets in my ppt, loops through all of the shapes in each ppt, and deletes the ppt if a specific string of text is not found. It seems to work perfectly other than the code seems to stop looping for no reason. I have to hit F5 about 4 times for the code to loop through all the sheets. It could be something to do with my code so I thought I'd try the good people of Stackoverflow first.
Public Sub ExportMBR()
Dim oSld As Slide
Dim oShp As Shape
Dim strSearch As String
Dim i As Integer
strSearch = "R&T MBR"
i = 0
For Each oSld In ActivePresentation.Slides
Debug.Print (ActivePresentation.Slides.Count)
Debug.Print (oSld.Name)
For Each oShp In oSld.Shapes
If oShp.HasTextFrame Then
If oShp.TextFrame.TextRange.Find(strSearch) Is Nothing Then
Else
Debug.Print (oSld.Name & " Slide found")
i = i + 1
End If
End If
Next oShp
If i = 0 Then
Debug.Print (oSld.Name & " Deleting")
oSld.Delete
i = 0
End If
i = 0
Next oSld
myQ = "<afilepath>"
myName = myQ & "<anameformat>") & ".pptx"
ActivePresentation.SaveCopyAs myName
Call Shell("explorer.exe " & myQ, vbNormalFocus)
End Sub
There are 34 slides in my ppt, each run will loop through about 7 slides correctly identifying and deleting the slides I do not need, but then without any errors it will just stop looping and continue executing the rest of the code. The string is found on slides 17 and 18 if this makes a difference. I have added few bits extra to try and solve the problem like the debug.prints and the i = 0 but I just can't figure out what I'm doing wrong.
Many thanks in advance!
ppw

Whenever you delete any object within a collection as you loop through each object in that collection, you need to count backwards. So in these cases you cannot use the For Each oSld In ActivePresentation.Slides statement but do this instead:
Dim lCntr as Long
Dim oSld as Slide
For lCntr = ActivePresentation.Slides.Count to 1 Step -1
Set oSld = ActivePresentation.Slides(lCntr)
' Do your stuff here...
Set oSld = Nothing
Next
Download more free PowerPoint macros and add-ins at http://youpresent.co.uk

Because Find(strSearch) & oSld.Delete are at the same loop, you need to separate them !!
Address the slides which you want to del first and then del them.
For example: suppose that you have slide_1 & slide_2 & slide_3 and you want to del slide_1 & slide_2 & slide_3. Actually, your VBA only del slide_1 & slide_3.
In the loop For Each oSld In ActivePresentation.Slides, the finding sequence should be slide_1 => slide_2 => slide_3. However, the first loop cycle will del slide_1, the remaining slides count become 2 (slide_2 & slide_3), so second loop cycle will start from slide_3. That's the reason why.

Related

Listing the selected slide index numbers

I have a large presentation and I'm looking to select a number of slides positioned a different positions and receive a list of the slide index numbers. My idea is for this list to appear in a message box.
So far I have put together the below which gives me each slide number in different message boxes. I'm looking for a list to appear in 1 message box that I can copy and paste into an email.
Ideally I'd like to add some extra text to the message box so I can copy and paste to a pre made email. I can probably take that part on though.
Any help would be greatly received.
Sub ShowMeSlideNumbers()
Dim oSld As Slide
For Each oSld In ActiveWindow.Selection.SlideRange
MsgBox "The slide index of the current slide is:" & oSld.SlideIndex
Next oSld
Exit Sub
End Sub
You can do this by creating an array to store the selected index numbers. Then read the array numbers back in reverse order to create a string. Finally, display that string as part of a MsgBox:
Sub ShowMeSlideNumbers()
Dim oSld As Slide
Dim X As Integer, Y As Integer, arrSlideNumbers() As Integer
Dim strSlideNumbers As String
X = 0
For Each oSld In ActiveWindow.Selection.SlideRange
ReDim Preserve arrSlideNumbers(X)
arrSlideNumbers(X) = oSld.SlideIndex
X = X + 1
Next oSld
For Y = UBound(arrSlideNumbers) To 2 Step -1
strSlideNumbers = strSlideNumbers & CStr(arrSlideNumbers(Y)) & ", "
Next Y
strSlideNumbers = strSlideNumbers & CStr(arrSlideNumbers(1)) & " and "
strSlideNumbers = strSlideNumbers & CStr(arrSlideNumbers(0))
MsgBox "The slide indices of the selected slides are: " & strSlideNumbers & "."
End Sub
A simple mod of your existing code should do it:
Sub ShowMeSlideNumbers()
Dim oSld As Slide
Dim sTemp as string
For Each oSld In ActiveWindow.Selection.SlideRange
sTemp = sTemp & "The slide index of the current slide is:" & oSld.SlideIndex & VbCRLF
Next oSld
MsgBox sTemp
End Sub

How can I split a PowerPoint file with multiple slides into multiple files of 1 slide each?

I have a file containing 50 slides. I need to create 50 different files each containing one of the slides. I guess the quickest way includes VBA, but I don't know how to get VBA to create a new file and then get back to the master.
Assuming you meant "create 50 presentations", this will work. Create the destination folder before running the code:
Sub ExportSlides()
For X = 1 To ActivePresentation.Slides.Count
ActivePresentation.Slides(X).Export "c:\temp\slide" & X & ".pptx", "PPTX"
Next X
End Sub
I finally found out this:
Sub ExportSlides()
Dim oTempPres As Presentation
Dim X As Long
For X = 1 To ActivePresentation.Slides.Count
sFileName = "C:\Raw\Slide__" & X & ".pptx"
ActivePresentation.SaveCopyAs sFileName
Set oTempPres = Presentations.Open(sFileName, , , False)
For Y = (X + 1) To oTempPres.Slides.Count
oTempPres.Slides(X + 1).Delete
Next
For Y = 1 To X - 1
oTempPres.Slides(1).Delete
Next
oTempPres.Save
oTempPres.Close
Next X
End Sub
This code I had for a similar project should work to split out each PPT file to its PPT file and save it to the folder that contains the original PPT file.
Some caveats:
it struggles with embedded graphs and sometimes backgrounds.
this strips out all animations assigned to the slides or the template. If you want to keep animations or effects in, just strip out those lines of code
I haven't taken the time to smooth out automating the UserForm showing up automatically, but you can easily run it by going to the Developer tab and running the OnPresentationOpen subroutine from the macros list.
Depending on your environment's security settings, you may also need to set the .pptm containing this VBA as a Trusted Document before it will work.
Option Explicit
Sub OnPresentationOpen()
UserForm1.Show
End Sub
Public Sub ProcessPowerPoint(pptCalled)
Dim pptMainPowerPt As Presentation
Dim slideCount As Long
Dim i As Long
Dim cleanSlide As Slide
Dim newSaveName As String
Set pptMainPowerPt = Presentations.Open(pptCalled)
slideCount = ActivePresentation.Slides.Count
' Removes all animations from entire document first
For Each cleanSlide In ActivePresentation.Slides
For i = cleanSlide.TimeLine.MainSequence.Count To 1 Step -1
'Remove Each Animation
cleanSlide.TimeLine.MainSequence.Item(i).Delete
Next i
Next cleanSlide
Debug.Print "The number of slides is "; slideCount
Debug.Print "The name that is showing is "; pptCalled
Debug.Print ActivePresentation.Name
newSaveName = Left(pptCalled, InStr(pptCalled, ".") - 1)
Debug.Print "Substring name is "; newSaveName
For i = 1 To slideCount
Dim newPresentation As Presentation
Dim newName As String
Dim currentSlide As Slide
newName = newSaveName + "_Slide_" & i & ".pptx"
Set currentSlide = pptMainPowerPt.Slides.Item(i)
Set newPresentation = Application.Presentations.Add
currentSlide.Copy
newPresentation.Slides.Paste
newPresentation.SaveAs (newName)
newPresentation.Close
Next
pptMainPowerPt.Close
End Sub

Export Only Slides Within a Certain Section in Powerpoint VBA

I have code that exports slides to PNG files if they meet certain criteria (i.e. have a certain named shape in the slide). There will be occassions where slides will not have any known shape names, but they will be within a named "section".
I know I must somehow use the ActivePresentation.SectionProperties, but I am not sure how to go about doing this. I've tried things along the line of the below code with no success. In this example the name of the section is "Test". There will be many different sections and I would need to do this for several of those sections. Any help would be much appreciated. Thank you!
Dim sld As Slide
i = 1
For Each sld in ActivePresentation.Slides
If ActivePresentation.SectionProperties.Name("Test") Then
ActivePresentation.Slides(i).Export filenamepng & "TEST" & i & ".png", "PNG"
End If
i = i + 1
Next
#Hunter21188
I guess this is what you need.
You will check of which section every slide belongs.
After this you verify if it's from "Test" section, if is true gotcha! Export.
Obs. The function convert SectionIndex, from Slide Atribute to SectionName, that is not in Slides collection.
Sub Test_Export()
Dim sld As Slide
i = 1
DesiredSection = SectionIndexOf("Test")
For Each sld In ActivePresentation.Slides
If sld.sectionIndex = DesiredSection Then
ActivePresentation.Slides(i).Export filenamepng & "TEST" & i & ".png", "PNG"
End If
i = i + 1
Next
End Sub
Function SectionIndexOf(sSectionName As String) As Long
Dim x As Long
With ActivePresentation.SectionProperties
For x = 1 To .Count
If .Name(x) = sSectionName Then
SectionIndexOf = x
End If
Next
End With
End Function

How to apply this VBA to multiple PPT files in a folder

I would like this particular code to be run on multiple powerpoint files in a folder. But it would be even better if it would open the powerpoint file, run this code below, save it and then open the next one. Any suggestions are welcome! I have been through code on this website, but can't seem to adapt it to my code below (e.g. this one Loop through files in a folder using VBA?)
LOOPING ATTEMPT
flag
Sub LoopThroughFiles()
Dim MyObj As Object, MySource As Object, file As Variant
file = Dir("c:\testfolder\")
While (file <> "")
If InStr(file, "test") > 0 Then
MsgBox "found " & file
Exit Sub
End If
file = Dir
Wend
End Sub
Existing Code
Option Explicit
' Selects the shape that support text which is closest to the top of the slide
' Written by Jamie Garroch of YOUpresent Ltd (http://youpresent.co.uk)
Sub SelectHigestTextShape()
Dim oSld As Slide
Dim oShp As Shape, oShpTop As Shape
Dim sShpTop As Single
On Error Resume Next
Set oSld = ActiveWindow.View.Slide
If Err Then Exit Sub
On Error GoTo 0
' Set the top to the bottom of the slide
sShpTop = ActivePresentation.PageSetup.SlideHeight
' Check each shape on the slide is positioned above the stored position
' Shapes not supporting text and placeholders are ignored
For Each oShp In oSld.Shapes
If oShp.Top < sShpTop And oShp.HasTextFrame And Not oShp.Type = msoPlaceholder Then
sShpTop = oShp.Top
Set oShpTop = oShp
End If
Next
' Select the topmost shape
If Not oShpTop Is Nothing Then oShpTop.Select msoTrue
ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
' Clean up
Set oSld = Nothing
Set oShp = Nothing
Set oShpTop = Nothing
End Sub
That's my code sample for the SelectHigestTextShape sub but I'm not sure it'll work the way you want for multiple files. The reason is that it was designed to SELECT a textbox object within the ACTIVE PRESENTATION using the ACTIVE VIEW. None of this exists when you loop through files in a folder as you'd need to open each one in turn but even then, what would be the point of selecting a shape only to close the presentation afterwards? I guess we really need to know the end goal. In the type of batch processing you're attempting, it would not be a good idea to select anything at all as that requires the object's view to be active which is a debugging nightmare and slows everything down a lot. If you want to do something with a particular object, it's much better to use a reference to it without requiring an active view or even an active window (you could open each file invisibly, process it and then close it).
This example will loop through a folder, open each presentation it finds (without a window), loop through all shapes on all slides, output a count of slides and shapes to the immediate pane, and then close the file:
' Loop through all PowerPoint files in a specified folder
' Open each and then loop through each shape of each slide
' Output a count of slides and shapes in immediate pane before closing the file
' Modified by Jamie Garroch of YOUpresent Ltd (http://youpresent.co.uk)
Sub LoopThroughPPTFiles()
Dim oPres As Presentation, oSld As Slide, oShp As Shape
Dim SldCount As Long, ShpCount As Long
Dim MyFile As String
Const MyFolder = "c:\testfolder\"
On Error GoTo errorhandler
MyFile = Dir(MyFolder)
While (MyFile <> "")
If Right(MyFile, 5) Like ".ppt*" Then
Set oPres = Presentations.Open(FileName:=MyFolder & MyFile, ReadOnly:=msoTrue, Untitled:=msoFalse, WithWindow:=msoFalse)
For Each oSld In oPres.Slides
SldCount = SldCount + 1
For Each oShp In oSld.Shapes
ShpCount = ShpCount + 1
Next
Next
Debug.Print oPres.Name & " has " & SldCount & " slide(s) and " & ShpCount & " shapes."
SldCount = 0: ShpCount = 0
oPres.Close
End If
MyFile = Dir
Wend
' clean up
Set oPres = Nothing: Set oSld = Nothing: Set oShp = Nothing
Exit Sub
errorhandler:
If Not oPres Is Nothing Then oPres.Close: Set oPres = Nothing
End Sub
You could use this to then examine the shapes after the "For Each oShp In oSld.Shapes" line to find the one positioned highest on the slide and then process it (without selecting it).

PowerPoint VBA search and delete paragraphs in Notes

I have several PowerPoints with a great deal of text in the notes. I need to search the note text and delete any paragraphs that start with "A."
Here is what I tried - but am getting type mismatch error
Dim curSlide As Slide
Dim curNotes As Shape
Dim x As Long
For Each curSlide In ActivePresentation.Slides
Set curNotes = curSlide.NotesPage.Shapes(2).TextFrame.TextRange
With curNotes.TextFrame.TextRange
For x = 1 To Len(curNotes.TextFrame.TextRange)
If Mid(curNotes.TextFrame.TextRange, x, 2) = "A." Then
curNotes.TextFrame.TextRange.Paragraphs = ""
End If
Next x
End With
Next curSlide
End Sub
Thanks for your help!!
You get a mismatch error whenever you try to assign data of a different type specified by your variable. This is happening in your code because you defined curNotes as type Shape and then tried to set that object variable to a different data type, TextRange. You are then trying to process the object TextRange as a string. You need to work on the .Text child of .TextRange The use of Mid is not checking the start of the string and finally, when you set the text to "", you are deleting all the text in the Note but that's not what you said you're trying to do.
This is the corrected code to delete only paragraphs starting with "A."
' PowerPoint VBA macro to delete all slide note paragraphs starting with the string "A."
' Rewritten by Jamie Garroch of youpresent.co.uk
Option Explicit
Sub DeleteNoteParagraphsStartingA()
Dim curSlide As Slide
Dim curNotes As TextRange
Dim iPara As Long
For Each curSlide In ActivePresentation.Slides
Set curNotes = curSlide.NotesPage.Shapes(2).TextFrame.TextRange
With curNotes
' Count backwards in any collection when deleting items from it
For iPara = .Paragraphs.Count To 1 Step -1
If Left(.Paragraphs(iPara), 2) = "A." Then
.Paragraphs(iPara).Delete
Debug.Print "Paragraph " & iPara & " deleted from notes pane on slide " & curSlide.SlideIndex
End If
Next
End With
Next curSlide
End Sub