Hmmm.... on second thought, maybe this might be more appropriate
Failing this, sorry but you will have to wait for the experts to view your post.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





Reply With Quote