Creating a batch of slides with titles based on Bullet Point in a "Master" slide

[SawdustDan]

I'm new to VBA with PowerPoint. Long-time user of VBA in Excel.

I am a college professor creating PowerPoint lesson plans and tools for students.

I am creating a powerpoint presentation where slide 1 has a bulleted list of vocabulary terms for the chapter.

Since I have numerous courses I teach, and 10-12 chapters in the textbook used for each course, I want to automate the next part using VBA:

I want to loop through all the bullets on a given slide (the "home" slide) and create a set of additional slides, each one having its title set to the text of that bullet.

Additionally, I want to create hyperlinks on the "home" slide that link from each bullet on the home slide to its corresponding definition slide.

So, I need to:

Loop through all bullets
Capture text of bullet
Create New Slide
Insert bullet text into slide
Create link to new slide
Paste that link to the current bullet on home slide

Thanks in advance for any assistance.

[Aussiebear]

Not sure but does this do what you want?



Sub CreateSlidesFromMasterBullets()
Dim oPres As Presentation
Dim oMasterSlide As Slide
Dim oShape As Shape
Dim oNewSlide As Slide
Dim i As Long
' Set the presentation and master slide
Set oPres = ActivePresentation
' Assuming the master slide is the first master slide
Set oMasterSlide = oPres.SlideMaster
' Loop through all shapes on the master slide
For Each oShape In oMasterSlide.Shapes
' Check if the shape is a text frame and has bullets
If oShape.HasTextFrame Then
If oShape.TextFrame.HasText Then
If oShape.TextFrame.TextRange.Paragraphs.Count > 1 Then
' Check for multiple paragraphs (bullets)
' Loop through each paragraph (bullet)
For i = 1 To oShape.TextFrame.TextRange.Paragraphs.Count
' Get the bullet text
Dim bulletText As String
bulletText = oShape.TextFrame.TextRange.Paragraphs(i).Text
' Create a new slide
Set oNewSlide = oPres.Slides.Add(oPres.Slides.Count + 1, ppLayoutTitleOnly)
' Set the title of the new slide to the bullet text
oNewSlide.Shapes(1).TextFrame.TextRange.Text = bulletText
Next i
Exit Sub
' Exit after processing the first shape with bullets.
End If
End If
End If
Next oShape
MsgBox "No bulleted list found on the Master Slide."
End Sub

[Aussiebear]

Hmmm.... on second thought, maybe this might be more appropriate



Sub CreateSlidesFromBullets()
Dim oSl As Slide
Dim oSh As Shape
Dim oTxRng As TextRange
Dim oBullet As TextRange
Dim newSlide As Slide
Dim newSlideLink As Hyperlink
Dim currentSlide As Slide
Dim bulletSlideIndex As Long
' Set the current slide
Set currentSlide = ActiveWindow.View.Slide
' Loop through all shapes on the current slide
For Each oSh In currentSlide.Shapes
' Check if the shape contains text
If oSh.HasTextFrame Then
Set oTxRng = oSh.TextFrame.TextRange
' Check if the text range has paragraphs (bullets)
If oTxRng.Paragraphs.Count > 0 Then
' Loop through each paragraph (bullet)
For Each oBullet In oTxRng.Paragraphs
' Check if the paragraph is a bullet
If oBullet.ParagraphFormat.Bullet.Visible Then
' Capture the bullet text
Dim bulletText As String
bulletText = oBullet.Text
' Create a new slide
Set newSlide = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutText)
newSlide.Shapes(1).TextFrame.TextRange.Text = bulletText
' Add title
' Create a text box for the body
Dim bodyBox As Shape
Set bodyBox = newSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 150, 600, 300)
bodyBox.TextFrame.TextRange.Text = "Add additional information here."
' Create a hyperlink to the new slide
Set newSlideLink = currentSlide.Hyperlinks.Add(oBullet, "", "", "", bulletText)
newSlideLink.SubAddress = newSlide.SlideIndex & ",1,0"
' Store the slide index for later use.
bulletSlideIndex = newSlide.SlideIndex
' Optional: Add a return link to the original slide on the new slide.
Dim returnLink As Hyperlink
Set returnLink = newSlide.Hyperlinks.Add(bodyBox.TextFrame.TextRange, "", "", "", "Return to Original Slide")
returnLink.SubAddress = currentSlide.SlideIndex & ",1,0"
End If
Next oBullet
End If
End If
Next oSh
MsgBox "Slides created and links added.", vbInformation
End Sub


Failing this, sorry but you will have to wait for the experts to view your post.

[SawdustDan]

Crikey Aussiebear, you are AUSSOME! I have one small bug to fix, but as it is, it successfully creates the new slides.

There are two lines that seem to make it gag a little

Set newSlideLink = currentSlide.Hyperlinks.Add(oBullet, "", "", "", bulletText)
and

Set returnLink = newSlide.Hyperlinks.Add(bodyBox.TextFrame.TextRange, "", "", "", "Return to Original Slide")

Each of those lines throws a "Method or data member not found" at the Hyperlinks.Add spot. I checked, and sure enough, Add is not a method for Hyperlinks

Hyperlinks only has 4 methods: Application, Count, Item and Parent.

So far, I've been unable to find a method that leads me to Add

Still working on it.

[Aussiebear]

Sadly my error comes from having an Excel background.

This line can create a hyperlink on a new slide

'Create the hyperlink to the new slide.
shp.Hyperlink.SubAddress = newSlide.SlideID & "," & newSlide.SlideIndex & "," & newSlide.Name

[SawdustDan]

The quest continues :dunno

So I first modified this line to use the oSh variable as you used in the original post.
Then it didn't like Hyperlink (Method or data member not found), so I changed that to Hyperlinks
Still doesn't like it. Lots of methods for Shape, but none of them are Hyperlink or Hyperlinks or anything else starting with "Hy" :dunno
Still working on it. Thank you for all your help thus far though

[Aussiebear]

Sorry for the delay but I'm waiting for the guru's to come by and view the thread.

[georgiboy]

How would the below work for you:

Sub CreateSlidesAndLinkBullets()
Dim ppt As Presentation
Dim srcSlide As Slide, newSlide As Slide
Dim shp As Shape, backTextBox As Shape
Dim slideIndex As Integer, originalSlideIndex As Integer, para As Integer
Dim headingText As String
Dim textRange As textRange
Dim slideWidth As Single, slideHeight As Single

Set ppt = ActivePresentation
Set srcSlide = ActiveWindow.View.Slide
originalSlideIndex = srcSlide.slideIndex
slideWidth = ppt.PageSetup.slideWidth
slideHeight = ppt.PageSetup.slideHeight

For Each shp In srcSlide.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
For para = 1 To shp.TextFrame.textRange.Paragraphs.Count
headingText = Trim(shp.TextFrame.textRange.Paragraphs(para).Text)
If headingText <> "" Then
slideIndex = ppt.Slides.Count + 1
Set newSlide = ppt.Slides.Add(slideIndex, ppLayoutText)
newSlide.Shapes.Title.TextFrame.textRange.Text = headingText
Set textRange = shp.TextFrame.textRange.Paragraphs(para)
textRange.ActionSettings(ppMouseClick).Hyperlink.SubAddress = newSlide.SlideID & ", 0,0"
Set backTextBox = newSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, slideWidth - 150, 10, 140, 30)
backTextBox.TextFrame.textRange.Text = "Back to Menu"
backTextBox.TextFrame.textRange.Font.Size = 14
backTextBox.TextFrame.textRange.Font.Bold = msoTrue
backTextBox.TextFrame.textRange.ActionSettings(ppMouseClick).Hyperlink.SubA ddress = srcSlide.SlideID & ", 0,0"
End If
Next para
End If
End If
Next shp
End Sub