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




Reply With Quote