Sub Build_Index()
Dim Mstr As CustomLayout
Dim SlidePosition As Integer
Dim Activeslide As PowerPoint.Slide
Dim TOCSlide As PowerPoint.Slide
Dim I As Integer
Dim Issues As Collection
Dim Issue As String
Dim FoundSlide As PowerPoint.Slide
Dim bodyText As PowerPoint.TextFrame
Dim sldID As Long
Dim sldindx As Long
Dim hypStart As Long
'assign custom objects
Set Mstr = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(2)
Set Activeslide = Application.ActiveWindow.View.Slide
' determine required inputs
SlidePosition = Activeslide.SlideIndex
'insert slide to hold TOC at current location
Set TOCSlide = ActivePresentation.Slides.AddSlide(SlidePosition, Mstr)
TOCSlide.Shapes.Title.TextFrame.TextRange = "Index"
Set bodyText = TOCSlide.Shapes.Placeholders(2).TextFrame
'loop through each slide compiling TOC from slide titles
Set Issues = GetIssues
I = 1
For I = I To Issues.Count
Issue = Issues(I)
Debug.Print Issue
Set FoundSlide = FindSlide(Issue)
' add Issue to page as text
bodyText.TextRange.InsertAfter (Issue & " " & Chr(13))
' create a hyperlink entry for TOC rather than a simple text entry
' get the information required for the hyperlink
sldID = FoundSlide.SlideID
sldindx = FoundSlide.SlideIndex
' find the text string in the body
hypStart = InStr(1, bodyText.TextRange.Text, Issue, 1)
'make the text a hyperlink
With bodyText.TextRange.Characters(hypStart, Len(Issue)).ActionSettings(ppMouseClick).Hyperlink
.SubAddress = FoundSlide.slideNumber
End With
Debug.Print sldID & "," & sldindx & "," & Issue
Next I
'release object
Set Mstr = Nothing
Set Activeslide = Nothing
Set TOCSlide = Nothing
Set bodyText = Nothing
End Sub
Public Function GetIssues() As Collection
Dim Issues As New Collection
Issues.Add ("IS 485")
Issues.Add ("IS 486")
Issues.Add ("AR 650")
Set GetIssues = Issues
End Function
Public Function FindSlide(StrText As String) As PowerPoint.Slide
Dim sld As PowerPoint.Slide
Dim shp As PowerPoint.Shape
Dim txtRng As PowerPoint.TextRange
Dim rngFound As PowerPoint.TextRange
Dim I As Long
Dim n As Long
On Error GoTo errlbl
For Each sld In Application.ActivePresentation.Slides
'~~> Loop through each shape
For Each shp In sld.Shapes
'~~> Check if it has text
If shp.HasTextFrame Then
Set txtRng = shp.TextFrame.TextRange
'~~> Find the text
Set rngFound = txtRng.Find(StrText)
'~~~> If found
If Not rngFound Is Nothing Then
Set FindSlide = sld
Exit Function
End If
End If
Next
Next
Set shp = Nothing
Set sld = Nothing
Exit Function
errlbl:
MsgBox Err.Number & " " & Err.Description
End FunctionFor sure you would not hard code the list, I just do not now what access you have to the source data and code.
Maybe I am missing something, but this seems pretty common to me. All the OP seems to be doing is creating a report/brief and making a hyperlinked TOC/Index. What is klunky and unorthodox.
In my case I am exporting data from Access into PPT, creating formatted PPTs. Access is automating PPT and creating the hyperlinks.
So that is obviously the preferred option. If I understand you are creating your brief/report by Access automation. As Access creates slides, it should update the index/TOC. Create a slide, update the TOC/index. Is each slide a specific customer?
Unless you actually need the data in Excel, exporting from Access to Excel and from there to PowerPoint sounds dumb - and it's inefficient to do it that way even if you do need the data in Excel for some other purpose. Since you already have the data in Access and undoubtedly already know which slides the data populate, why are you not simply populating the slides directly from Access and adding the 'index' details to the first slide as you go? Furthermore, unless this presentation is primarily intended to be displayed via a projector, why are you outputting to PowerPoint at all? Why not use an Access report or a Word mailmerge (to which a TOC could easily be added)?