Create Powerpoint Slides and Add Titles and links

[historyman]

Hi

Someone kindly created this macro to create Powerpoint slides, with text and pictures, and it works very well.

The macro creates one slide for a person and adds text and a picture if it exists.

I know that some of the pictures overlap the text box, but as there are not many I don not mind manually correcting.

What I would like to do is title each slide using the value in column A and also create a first slide of links to each individual slide. Linking on the text box rather than the text is the preferred option.

Any help appreciated.

Option Explicit
Dim pp As PowerPoint.Application, ppPres As PowerPoint.Presentation, ppSlide As PowerPoint.Slide, ppShape As PowerPoint.Shape


Sub NewPresentation()


'worksheet range
Dim ws As Worksheet, Cel As Range
Set ws = Sheets("Sheet1")
'create presentation
Set pp = New PowerPoint.Application
Set ppPres = pp.Presentations.Add
pp.Visible = True 'msoTrue


'add slides
For Each Cel In ws.Range("A2", ws.Range("A" & Rows.Count).End(xlUp))
Call AddASlide(Cel, Cel.Offset(, 1), Cel.Offset(, 2), Cel.Offset(, 3))
Next
End Sub

Private Sub AddASlide(Person As Range, Story As Range, PathToPic As Range, Photo As Range)
On Error Resume Next


'create the slide
ppPres.Slides.Add ppPres.Slides.Count + 1, ppLayoutBlank

Set ppSlide = ppPres.Slides(ppPres.Slides.Count)

'add namebox & text
Set ppShape = ppSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, Left:=25, Top:=25, Width:=850, Height:=50)
ppShape.TextFrame.TextRange.Text = Person
ppShape.TextFrame.TextRange.Font.Size = 30
ppShape.TextFrame.TextRange.Font.Bold = True


'Check if photograph exists

If Photo = "Yes" Then


'insert picture
ppSlide.Shapes.AddPicture Filename:=PathToPic, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=50, Top:=100
With ppSlide.Shapes(ppSlide.Shapes.Count)
.LockAspectRatio = msoTrue
.Height = 300
End With
Else
' add larger text box

'add storybox & text
Set ppShape = ppSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, Left:=50, Top:=100, Width:=600, Height:=50)
ppShape.TextFrame.TextRange.Text = Story

End If

'add storybox & text
Set ppShape = ppSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, Left:=300, Top:=100, Width:=625, Height:=50)
ppShape.TextFrame.TextRange.Text = Story
ppShape.TextFrame.TextRange.ParagraphFormat.SpaceBefore = 6
ppShape.TextFrame.TextRange.Font.Size = 20

End Sub