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

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"
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.SubAddress = srcSlide.SlideID & ", 0,0"
                    End If
                Next para
            End If
        End If
    Next shp
End Sub