I have a command button and a text-box in the Slide Master of a PowerPoint presentation. I am trying to retrieve the PowerPoint's properties such as SlideID, SlideIndex and the name of the corresponding file and post them to the text box on the click of the command button.
At the moment I have this code but its giving me an error:
Sub CommandButton1_Click()
Dim Index As Long
Dim SlideId as Long
Dim FileName as String
TextBox1.Text = "SlideIndex:" & Index & "Slide ID:" & SlideId
End Sub
I want page 1 of the power point to read as slideIndex 1 SlideID 1 and the file name. and for slide 2 I want it to say all two's and so on...
Thanks in advance!
You can use a command button if you like; or you can use any PowerPoint shape you want to draw, assign it an Action Setting of Run Macro and choose the macro you want it to run when clicked.
Either way, this should work:
Sub ReportStuff()
Dim oSl As Slide
Dim oSh As Shape
Set oSl = SlideShowWindows(1).View.Slide
' Test to see if the shape's already there:
Set oSh = IsItThere(oSl, "My Text Box")
' If it's not there, add it:
If oSh is Nothing Then
Set oSh = oSl.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 200, 50)
oSh.Name = "My Text Box"
End If
With oSh.TextFrame.TextRange
.Text = "Index: " & oSl.SlideIndex & " ID: " & oSl.SlideID & " File: " & ActivePresentation.FullName
End With
End Sub
Function IsItThere(oSl as Slide, sName as String) as Shape
Dim oSh as Shape
For each oSh in oSl.Shapes
If oSh.Name = sName Then
Set IsItThere = oSh
Exit Function
End If
Next
End Function
Related
I have put together an e-learning module. I am still very new at vba though. I am trying to make a dynamic main menu which contains multiple text boxes. If the text in a text box matches the title of a slide, that shape should then then be hyperlinked to the corresponding slide. Ideally, the text boxes on the Main Menu would contain the names of Sections and hyperlink to the first slide in the named section, but I couldn't figure that out, so instead I made the title of the first slide in each section match the text. I've searched and searched and gotten as close as I could. I am hoping someone can help me finish it. I have gotten past several errors, and have the text hyperlinked, however all linked take the user to the last slide in the presentation instead of the proper slide. Thank you in advance for any guidance!!
Here is the code:
Sub TestMe()
'Original Source: http://www.steverindsberg.com/pptlive/FAQ00056.htm
Dim aSl As Slide 'active slide
Dim dSl As Slide 'destination slide
Dim Slde As Slide
Dim oSh As Shape
Dim aSl_ID As Integer
Dim aSl_Index As Integer
Dim dSl_ID As Integer
Dim dSl_Index As Integer
Dim sTextToFind As String
Dim hypstart As String
Dim Titl As String
Set aSl = Application.ActiveWindow.View.Slide 'active slide
aSl_Index = Application.ActiveWindow.View.Slide.SlideIndex 'active slide index
' Set ActiveSld_Index =
' Set DestinationSld_ID = oSl.SlideID
' Set DestinationSld_Index = oSl.SlideIndex
For Each oSh In aSl.Shapes
'If IsSafeToTouchText(oSh) = True Then
sTextToFind = oSh.TextFrame.TextRange.Text
'loop through slides looking for a title that matches the text box value
On Error Resume Next
Set dSl = FindSlideByTitle(sTextToFind)
' get the information required for the hyperlink
dSl_ID = CStr(dSl.SlideID)
dSl_Index = CStr(dSl.SlideIndex)
' find the text string in the body
hypstart = InStr(1, sTextToFind, sTextToFind, 1)
'make the text a hyperlink
With oSh.TextFrame.TextRange.Characters(hypstart, Len(sTextToFind)).ActionSettings(ppMouseClick).Hyperlink
.SubAddress = dSl_ID & "," & dSl_Index & "," & sTextToFind
End With
'End If
Next oSh
End Sub
Public Function FindSlideByTitle(sTextToFind As String) As Slide
'Source: http://www.steverindsberg.com/pptlive/FAQ00056.htm
Dim oSl As Slide
Dim oSh As Shape
With ActivePresentation
For Each oSl In .Slides
For Each oSh In oSl.Shapes
With oSh
'If .HasTextFrame Then
'If Not .TextFrame.TextRange.Text Is Nothing Then
'myPres.Slides(1).Shapes.Title.TextFrame.TextRange
On Error Resume Next
If UCase(.TextFrame.TextRange.Text) = UCase(sTextToFind) Then
'If UCase(.TextRange.Text) = UCase(sTextToFind) Then
Set FindSlideByTitle = oSl
'End If
End If
'End If
End With
Next
Next
End With
End Function
Public Function IsSafeToTouchText(pShape As Shape) As Boolean
'Source: http://www.steverindsberg.com/pptlive/FAQ00056.htm
On Error GoTo ErrorHandler
If pShape.HasTextFrame Then
If pShape.TextFrame.HasText Then
' Errors here if it's a bogus shape:
If Len(pShape.TextFrame.TextRange.Text) > 0 Then
' it's safe to touch it
IsSafeToTouchText = True
Exit Function
End If ' Length > 0
End If ' HasText
End If ' HasTextFrame
Normal_Exit:
IsSafeToTouchText = False
Exit Function
ErrorHandler:
IsSafeToTouchText = False
Exit Function
End Function
Here is the revised code. I have gone in circles and am now stuck. Any suggestions are much appreciated!
After I restored the original function (FindSlideByTitle), I kept getting an error on got an error on .textframe.textrange, making me think that the type of shape I used on my slide (freeform) needed TextFrame2, so I edited that, which fixed the error, but since then I've not been able to make the hyperlink work and have tried instead to use GoTo Slide by including the parent.
I even tried making an array of all freeform shapes on the slide, but I'm still new at this and perhaps I don't fully understand the concepts yet. As it currently stands, I don't get any errors, however, when I click one of the shapes, the shape's appearance changes from the click, but it doesn't go anywhere.
I have also included an image of the actual slide.
Sub TestLinkShapesToSlideTitles()
Dim aSl, dSl, oSl As Slide 'active slide, destination slide
Dim oSh As PowerPoint.Shape
Dim aSl_ID, dSl_ID As Integer
Dim aSl_Index, dSl_Index As Long
Dim dSl_Title, hypstart, Titl As String
Dim sTextToFind As String
Dim numshapes, numFreeformShapes As Long
Dim FreeformShpArray As Variant
Dim ShpRange As Object
Dim oPres As Presentation
Set aSl = Application.ActiveWindow.View.Slide 'active slide
aSl_Index = Application.ActiveWindow.View.Slide.SlideIndex 'active slide index
''''''''''''''''''''''''''''
'In this section I tried to make an array of all the freeform shapes on the slide, thinking that would help.
With aSl.Shapes
numshapes = .Count
'Continues if there are Freeform shapes on the slide
If numshapes > 1 Then
numFreeformShapes = 0
ReDim FreeformShpArray(1 To numshapes)
For i = 1 To numshapes
'Counts the number of Freeform Shapes on the Slide
If .Item(i).Type = msoFreeformShape Then
numFreeformShapes = numFreeformShapes + 1
FreeformShpArray(numFreeformShapes) = .Item(i).Name
End If
Next
'Adds Freeform Shapes to ShapeRange
If numFreeformShapes > 1 Then
ReDim Preserve FreeformShpArray(1 To numFreeformShapes)
Set ShpRange = .Range(FreeformShpArray)
'asRange.Distribute msoDistributeHorizontally, False
End If
End If
End With
''''''''''''''''''''''''''
On Error Resume Next
'Loop through all the shapes on the active slide
For Each oSh In aSl.Shapes
If oSh.Type = msoFreeform Then 'oSh.Type = 5
'If oSh.HasTextFrame Then
If oSh.TextFrame2.HasText Then 'results in -1
With oSh
sTextToFind = .TextFrame2.TextRange.Characters
'sTextToFind results in "Where to Begin"
'.TextFrame2.TextRange.Characters results in "Learn the Lingo", which is the shape after Where to Begin.
End With
End If
'End If
'If IsSafeToTouchText(oSh) = True Then
'With oSh.TextFrame
'sTextToFind = .TextRange.Characters.Text
'loop through slides looking for a title that matches the text box value
'For Each oSl In ActivePresentation.Slides
'If oSl.Shapes.HasTitle Then
'Titl = Slde.Shapes.Title.TextFrame.TextRange <<<<< I kept getting the error here...
On Error Resume Next
Set dSl = FindSlideByTitle_Original(sTextToFind)
' get the information required for the hyperlink
dSl_Title = dSl.Shapes.Title.TextFrame.TextRange
dSl_ID = dSl.SlideID
dSl_Index = dSl.SlideIndex
With oSh
.ActionSettings(ppMouseClick).Parent.Parent.View.GoToSlide dSl_Index, msoFalse 'Go to slide and don't reset animations
End With
' find the text string in the body
'hypstart = InStr(1, sTextToFind, dSl_Title, 1)
'make the text a hyperlink
'With oSh.TextFrame.TextRange.Characters(hypstart, Len(sTextToFind)).ActionSettings(ppMouseClick).Hyperlink
'.SubAddress = dSl_ID & "," & dSl_Index & "," & sTextToFind
'End With
'End With
End If
'End If
Next oSh
End Sub
Public Function FindSlideByTitle_Original(sTextToFind As String) As Slide
'Source: https://stackoverflow.com/questions/25038952/vba-powerpoint-select-a-slide-by-name
Dim oSl As Slide
For Each oSl In ActivePresentation.Slides
With oSl.Shapes.Title.TextFrame
If .HasText Then
If UCase(.TextRange.Text) = UCase(sTextToFind) Then
Set FindSlideByTitle_Original = oSl
End If
End If
End With
Next
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 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
I am working on a custom tool that generates customized Instructor notes for a given presentation. I am having a problem where I am processing a presentation where a slide basically has no Title object on it Then I run through the code it is bi-passing my if statements with .
I have reduced the code to the basics to make it as easy as possible.
My test lesson has a normal slide with the text place holder filled out, the next slide is a logo slide with no title text box, just a copyright information and logo, (this is the slide that is having issues) and then another slide where the title place holder is present, but left blank.
How do I check the individual slide to make sure that the title placeholder exists?
Public Sub GetTitle()
Dim pres As Presentation 'PowerPoint presentation
Dim sld As Slide 'Individual slide
Dim shp As Shape 'EIAG Text Shape
Dim ShpType As String 'Shape Type
Dim SldTitle As String 'Slide TITLE
'Go through each slide object
Set pres = ActivePresentation
For Each sld In ActivePresentation.Slides.Range
On Error Resume Next
If sld.Shapes(1).PlaceholderFormat.Type = ppPlaceholderCenterTitle Or sld.Shapes(1).PlaceholderFormat.Type = ppPlaceholderTitle Then
If sld.Shapes.Title.TextFrame.TextRange <> "" Then
SldTitle = sld.Shapes.Title.TextFrame.TextRange
Debug.Print SldTitle & " - Slide: " & CStr(sld.SlideNumber)
Else
Debug.Print "BLANK TITLE - Slide: " & CStr(sld.SlideNumber)
End If
Else
ShpType = sld.Shapes.Item(1).Type
Debug.Print ShpType & "Not Processed There is no Title object"
End If
Next sld
End Sub
You can use the HastTitle method of the Shapes Collection to check if a slide has a title placeholder:
If sld.Shapes.HasTitle then
You should also not rely on the title placeholder being shape 1 and rather loop through all shapes on the slide, checking each one as follows:
Option Explicit
' Function to return an array of title texts from a presentation
' Written by Jamie Garroch at http://youpresent.co.uk
' Inputs : None
' Outputs : Array of title strings
Function GetTitlesArr() As Variant
Dim oSld As Slide
Dim oShp As Shape
Dim iCounter As Integer
Dim arrTitles() As String
For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
With oShp
If .Type = msoPlaceholder Then
Select Case .PlaceholderFormat.Type
Case ppPlaceholderCenterTitle, ppPlaceholderTitle
ReDim Preserve arrTitles(iCounter)
arrTitles(iCounter) = oShp.TextFrame.TextRange.Text
iCounter = iCounter + 1
End Select
End If
End With
Next
Next
GetTitlesArr = arrTitles
End Function
I am using a code to present the presentation properties to a textbox or shape via a command button or Macro. When I run it I get a run time error that say " SlideShowWindows(unknown member): integer out of range. 1 is not in the valid range of 1 to 0
What should I do!?
Thanks in advance!
Sub ReportStuff()
Dim oSl As Slide
Dim oSh As Shape
Set oSl = SlideShowWindows(1).View.Slide
' Test to see if the shape's already there:
Set oSh = IsItThere(oSl, "My Text Box")
' If it's not there, add it:
If oSh Is Nothing Then
Set oSh = oSl.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 200, 50)
oSh.Name = "My Text Box"
End If
With oSh.TextFrame.TextRange
.Text = "Index: " & oSl.SlideIndex & " ID: " & oSl.SlideID & " File: " & ActivePresentation.FullName
End With
End Sub
Function IsItThere(oSl As Slide, sName As String) As Shape
Dim oSh As Shape
For Each oSh In oSl.Shapes
If oSh.Name = sName Then
Set IsItThere = oSh
Exit Function
End If
Next
End Function
SlideShowWindow is only accessible during a slideshow, not in normal/ edit mode. Adding the following line of code above Set oSl = SlideShowWindows(1).View.Slide should help:
ActivePresentation.SlideShowSettings.run