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
Related
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
I am very new at vba and need some guidance please. I am trying to add a text box to each slide (outside of the slide area), to view a slide's ID and Index at a quick glance. I have pieced together several bits to create the code below. it works, however the number of text boxes added to each slide is the number of slides in the presentation (112) instead of 1. I would also like to know how I can adapt this to be refreshed when changes to the slides are made.
Thanks in advance!
Here is the code:
Sub AddSlideInfo()
'Original Source: http://www.pptfaq.com/FAQ01180-Add-presentation-file-name-to-each-slide-master.htm
Dim x As Long
Dim oSh As Shape
Dim oSl As Slide
With ActivePresentation
On Error Resume Next 'In case the shape does not exist.
' On each slide in the presentation:
For x = 1 To .Slides.Count
Set oSl = ActivePresentation.Slides(x)
' Create a textbox at 0" from left,
' -120.24 points from top of slide ( -1.67") from top left corner
' Make it 90 points high, 300 points wide 1.25" x 5.5"
' Change any of these numbers at will
For Each oSl In ActivePresentation.Slides
With oSl
Set oSh = .Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=0, Top:=-120, Width:=300, Height:=90)
' Give it a name so we can find it later
oSh.Name = "SlideInfo"
'Add some formatting and dummy text
With oSh.TextFrame.TextRange
.Font.Name = "Berlin Sans Demi"
.Font.Size = 12
.Text = _
"Slide Info: " & vbNewLine & _
"Slide Index: " & oSl.SlideIndex & vbNewLine & _
"Slide ID: " & oSl.SlideID
End With
End With
Next
Next x
End With
End Sub
Your code loops though all the slides with the For x = 1 To .Slides.Count and then loops through all slides again with For Each oSl In ActivePresentation.Slides. You don't need both.
The following is a simplified version of your code. It only loops through the slides once. It deletes the SlideInfo textbox if it exists (using On Error Resume Next to catch the error) ... but you can clean that up later :) ... and then recreates the textbox cleanly each time.
Option Explicit
Sub AddSlideInfo()
Const cShapeName = "SlideInfo"
Dim oSh As Shape
Dim oSl As Slide
On Error Resume Next
With ActivePresentation
For Each oSl In ActivePresentation.Slides
With oSl
.Shapes(cShapeName).Delete
Set oSh = .Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=0, Top:=-120, Width:=300, Height:=90)
oSh.Name = cShapeName
'Add some formatting and dummy text
With oSh.TextFrame.TextRange
.Font.Name = "Berlin Sans Demi"
.Font.Size = 12
.Text = _
"Slide Info: " & vbNewLine & _
"Slide Index: " & oSl.SlideIndex & vbNewLine & _
"Slide ID: " & oSl.SlideID
End With
End With
Next
End With
End Sub
I hope this is a super simple question but for some reason i cant figure it out.
I need to delete a subset of the selected shapes on a powerpoint slide using VBA. I can do this using:
ActivePresentation.Slides(1).Shapes.Range(_Index_).Delete
Where _Index_ is either an array of shape indexes (integers) or shape names (stings).
Since the shape names are not unique (and people i am making this macro for have a nasty habit of having multiple shapes with the same name) i need to rely on the shape index number. My problem is i dont know how to get the index number of a given shape.
I can only see how i get the shape name or shape ID using:
ActiveWindow.Selection.ShapeRange(IdNum).Name
ActiveWindow.Selection.ShapeRange(IdNum).ID
So my question is: How do i get the shape index of selected shapes?
When you group a selection of shapes, the group becomes a new shape appended to the end of the previous z-order position. All of the individual shapes within the group are appended to the z-order after the group shape itself.
I can't find a way of determining which individual item within a group is selected (sub-selected, I guess we should say, since the original parent group remains selected and that's what PPT returns when you query ActiveWindow.Selection.ShapeRange(1).
To identify the currently subselected item within a group, you can use this as a starting point:
Sub WorkWithSubSelectedShapes()
' Do stuff with sub-selected shapes within a group
' Courtesy of Andy Pope
Dim oSh As Shape
Dim oGSh As Shape
Dim x As Long
Set oSh = ActiveWindow.Selection.ShapeRange(1)
' Do something with each shape in the group:
For Each oGSh In oSh.GroupItems
Debug.Print oGSh.TextFrame.TextRange.Text
Next
' Now do something with each SUB-SELECTED
' shape within the group
With ActiveWindow.Selection.ChildShapeRange
For x = 1 To .Count
Debug.Print .Item(x).Name
Debug.Print .Item(x).TextFrame.TextRange.Text
Next
End With
End Sub
Here's some code that may help generally in processing shapes/groups. It takes account of the fact that there might be groups within groups (within groups (within groups)) ...
Sub ProcessShapes()
Dim oSh As Shape
For Each oSh In ActivePresentation.Slides(1).Shapes
If oSh.Type = msoGroup Then
Debug.Print "GROUP" & vbTab & oSh.Name & vbTab & oSh.ZOrderPosition
Call DealWithGroup(oSh)
Else
Debug.Print oSh.Name & vbTab & oSh.ZOrderPosition
End If
Next
End Sub
Sub DealWithGroup(oSh As Shape)
Dim x As Long
For x = 1 To oSh.GroupItems.Count
If oSh.GroupItems(x).Type = msoGroup Then
Call DealWithGroup(oSh.GroupItems(x))
Else
Debug.Print "GROUP ITEM" & vbTab & oSh.GroupItems(x).Name & vbTab & oSh.GroupItems(x).ZOrderPosition
End If
Next
End Sub
And to answer Peter's further (excellent) question, this should work:
Sub TestIndexOf()
MsgBox IndexOf(ActiveWindow.Selection.ShapeRange(1))
End Sub
Function IndexOf(oSh As Shape) As Long
Dim x As Long
With ActiveWindow.Selection.SlideRange.Shapes
For x = 1 To .Count
If .Item(x).Name = oSh.Name Then
' Found it, report it
IndexOf = x
End If
Next
End With
End Function
Try the few lines of code and yow will get names of all the shapes in immediate window (Cttl+G to view Immediate window)
Dim shp As Shape, I As Integer
For Each shp In ActivePresentation.Slides(1).Shapes
I = I + 1
Debug.Print "Index=" & I & " Name= " & shp.Name & " ID= " & shp.Id & " Type= " & shp.Type
Next
I have added a label in PowerPoint 2013 with the following code to show "x of y" at the bottom of all slides, where x is current slide number and y is total number of slides:
Private Sub Label1_Click()
Dim p1 As String
p1 = " of "
Dim p2 As Integer
Dim slideNumber As String
slideNumber = ActiveWindow.Selection.SlideRange.slideNumber
p2 = ActivePresentation.Slides.Count
Label1.Caption = slideNumber & p1 & p2
End Sub
The code works perfectly for the slide on which I have added the label e.g. it shows "9 of 29" for slide 9 of my total 29 slides, however when I copy and paste the label on other slides, it still shows "9 of 29" which is wrong as I expect it to automatically reflect the current slide number.
If you want this to work across all slides, wouldn't it be simpler to have a single button whose click updates all of the slide numbers at one time?
Assuming you have a shape named "SlideNumber" on every slide:
Sub ForExample()
Dim oSl As Slide
For Each oSl In ActivePresentation.Slides
With oSl.Shapes("SlideNumber").TextFrame.TextRange
.Text = "Slide " & CStr(oSl.SlideIndex) & " of " _
& CStr(ActivePresentation.Slides.Count)
End With
Next
End Sub
Here is my solution. Add a new textbox if it does not exist; otherwise use the existing one. That way, you can rerun the macro after making changes to slides.
Sub SlideNum()
For Each oSl In ActivePresentation.Slides
exist = False
For Each oS in Osl.Shapes
If oS.name = "SlideNum" Then
exist = True
Exit For
End If
Next
If exist = False Then
' convert from inch *72
Set oshp = oSl.Shapes.AddTextbox(msoTextOrientationHorizontal, 25.55*72, 14.21*72, 1.12*72, 20)
oshp.name = "SlideNum"
Else
Set oshp = oS
End If
With oshp.TextFrame.TextRange
' .Text = CStr(oSl.SlideIndex) & "/" & CStr(ActivePresentation.Slides.Count)
.Text = CStr(oSl.SlideIndex)
.Font.Size = 40
End With
Next
End Sub
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.