Automation to pull in slides from directories

[Bufger]

Using Powerpoint 2010.

There are 2 challenges i'm facing with this small project.

I'm trying to have one master blank presentation with a pull macro to pull in slides from multiple directories (ie other people do the slides on a common format, put them in a shared directory area and this macro pulls them in to one presentation.

ie it pulls from U:\ProjectX\Team\MeetingInputs\Team1 (Team2, Team3) etc

I want it to pull all slides from each incase the number of slides differed week on week.

Heres the latest ive been messing about with:


Sub Pull()
Dim SrcDir As String, SrcFile As String
SrcDir = PickDir()
If SrcDir = "" Then Exit Sub
SrcFile = Dir(SrcDir & "Input.pptx")
Do While SrcFile <> "Input.pptx"
ImportFromPPT SrcDir + "\" + SrcFile, 1, 2
SrcFile = Dir()
Loop
End Sub
Private Function PickDir() As String
Dim FD As FileDialog
PickDir = "U:\ProjectX\Team\MeetingInputs\Team1"
Set FD = Application.FileDialog(msoFileDialogFolderPicker)
With FD
.Title = "U:\ProjectX\Team\MeetingInputs\Team1"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count <> 0 Then
PickDir = .SelectedItems(1)
End If
End With
End Function


The second challenging part is getting it to keep hyperlinks hitting the correct pages by slide title rather than number! For that i've tried the following without success (no errors, just doesnt seem to work):

Option Explicit
Sub ResetLinksToTitles()
Dim oPres As Presentation
Dim oSld As Slide
Dim I As Integer
Dim Titles() As String
Dim Target() As String
Dim TargetSlideIndex As Long
Dim sNewLink As String
Dim Ctr As Long
Set oPres = ActivePresentation
Ctr = 0
'Load all the titles
ReDim Titles(1 To oPres.Slides.Count)
For I = 1 To oPres.Slides.Count
If oPres.Slides(1).Shapes.HasTitle Then
If oPres.Slides(1).Shapes.Title.TextFrame.HasText Then
Titles(I) = oPres.Slides(I).Shapes.Title.TextFrame.TextRange.Text
End If
End If
Next
For Each oSld In oPres.Slides
For I = 1 To oSld.Hyperlinks.Count
With oSld.Hyperlinks(I)
If .Address = "" Then
Erase Target
'Get the link info and parse it.
Target = Split(.SubAddress, ",")
'Locate a slide for that title, if any.
If Len(Trim(Target(2))) > 0 Then
TargetSlideIndex = FindSlideByTitle(Target(2), Titles)

If TargetSlideIndex > 0 Then
' Check if the id of the slide found already matches the existing link
If Val(Target(0)) <> oPres.Slides(TargetSlideIndex).SlideID Then
' If not then update the link with the new id and slide index.
sNewLink = CStr(oPres.Slides(TargetSlideIndex).SlideID) & _
"," & CStr(TargetSlideIndex) & "," & Target(2)
Debug.Print "Changing " & .SubAddress & " to " & sNewLink
.SubAddress = sNewLink
Ctr = Ctr + 1
End If
End If
End If
End If
End With
Next
Next
Debug.Print CStr(Ctr) & " links changed."
End Sub
Function FindSlideByTitle(Title As String, Titles() As String) As Long
Dim I As Integer
FindSlideByTitle = -1
For I = 1 To UBound(Titles)
If Title = Titles(I) Then
FindSlideByTitle = I
Exit Function
End If
Next
End Function




I'd really appreciate somebody with experience helping me out with this. I havent written a macro in years and i'm feeling a little short of ideas now! I dont think i'm approaching it the right way.

Many thanks,

Andy

[John Wilson]

Problem 1

There's no such method as ImportFromPPT AFAIK

If there is just one pptx called Input.pptx in the chosen folder try:

Sub Pull()
Dim SrcDir As String, SrcFile As String
SrcDir = PickDir()
If SrcDir = "" Then Exit Sub
SrcFile = "Input.pptx"
ActivePresentation.Slides.InsertFromFile FileName:=SrcDir + "\" + SrcFile, Index:=ActivePresentation.Slides.Count
End Sub
Private Function PickDir() As String
Dim FD As FileDialog
PickDir = "U:\ProjectX\Team\MeetingInputs\Team1"
Set FD = Application.FileDialog(msoFileDialogFolderPicker)
With FD
.Title = "U:\ProjectX\Team\MeetingInputs\Team1"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count <> 0 Then
PickDir = .SelectedItems(1)
End If
End With
End Function


Not sure how you intend to hyperlink to slides by Title as the Title of slides is not unique. If you hhave created a presentation where this is designed in then you need to explain EXACTLY what you need.

[John Wilson]

Maybe this for 2

Sub ResetLinksToTitles()
Dim oPres As Presentation
Dim oSld As Slide
Dim I As Integer
Dim Titles() As String
Dim Target() As String
Dim TargetSlideIndex As Long
Dim sNewLink As String
Dim Ctr As Long
Set oPres = ActivePresentation
Ctr = 0
'Load all the titles
ReDim Titles(1 To oPres.Slides.Count)
For I = 1 To oPres.Slides.Count
If oPres.Slides(I).Shapes.HasTitle Then
Titles(I) = oPres.Slides(I).Shapes.Title.TextFrame.TextRange.Text
Else
Titles(I) = "No Title"
End If
Next
For Each oSld In oPres.Slides
For I = 1 To oSld.Hyperlinks.Count
With oSld.Hyperlinks(I)
If .Address = "" Then
Erase Target
'Get the link info and parse it.
Target = Split(.SubAddress, ",")
'Locate a slide for that title, if any.

If Len(Trim(Target(2))) > 0 Then
TargetSlideIndex = FindSlideByTitle(Target(2), Titles)

If TargetSlideIndex > 0 Then
' Check if the id of the slide found already matches the existing link
If Val(Target(0)) <> oPres.Slides(TargetSlideIndex).SlideID Then
' If not then update the link with the new id and slide index.
sNewLink = CStr(oPres.Slides(TargetSlideIndex).SlideID) & _
"," & CStr(TargetSlideIndex) & "," & Target(2)
Debug.Print "Changing " & .SubAddress & " to " & sNewLink
.SubAddress = sNewLink
Ctr = Ctr + 1
End If
End If
End If
End If
End With
Next
Next
Debug.Print CStr(Ctr) & " links changed."
End Sub
Function FindSlideByTitle(Title As String, Titles() As String) As Long
Dim I As Integer
For I = 1 To UBound(Titles)
If Title = Titles(I) Then
FindSlideByTitle = I
Exit Function
End If
Next
End Function

But it depends on the Title not being changed and being unique

[Bufger]

John,

The first one has it working, its now pulling in input.pptx from a specified location. Would i have to repeat the strings to have the same macro pull in the other named presentations? In the same folder I could have input1.pptx, input2.pptx etc. This is basically for multiple teams to give their inputs which can be collated by one master presentation. I tried modifying it slightly but it will only pull in the last named SrcFile.

I'll try out the possible solution to #2 now. Many thanks for your time and effort it really is appreciated.

Ta

[John Wilson]

Yep - it wasn't clear whether there was more than one file in the folder. I think this is what you were trying to do in the original code (import slides from all .pptx in the folder):

Sub Pull()
Dim SrcDir As String, SrcFile As String, strSpec As String
strSpec = "*.pptx"
SrcDir = PickDir()
If SrcDir = "" Then Exit Sub
SrcFile = Dir$(SrcDir & "\" & strSpec) ' first match
While SrcFile <> ""
ActivePresentation.Slides.InsertFromFile FileName:=SrcFile, Index:=ActivePresentation.Slides.Count
SrcFile = Dir() 'next match if any
Wend
End Sub
Private Function PickDir() As String
Dim FD As FileDialog
PickDir = "U:\ProjectX\Team\MeetingInputs\Team1"
Set FD = Application.FileDialog(msoFileDialogFolderPicker)
With FD
.Title = "U:\ProjectX\Team\MeetingInputs\Team1"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count <> 0 Then
PickDir = .SelectedItems(1)
End If
End With
End Function

[Bufger]

Don't worry I've figured that out, it would work out better if I did them on separate modules and ran them separately just incase one team didn't have their input in i could still collate the rest.

To clarify issue 2 - If I had Master.pptx pulling in all of these other presentations and say input2.pptx had 2 slides - 1 visible main slide with a hyperlink to 1 hidden reference slide (slide 2) and slide 2 had a hyperlink 'back' button to return to slide 1. I would want to keep these hyperlinks rather than the hyperlink to slide 2 taking me to slide 2 of the master.pptx. I'm not sure if naming the slides helps at all or whether there is a condition to keep original hyperlink formatting/destination.

I hope that made more sense. If not let me know and i'll write out another example.

Thanks again

[John Wilson]

It's going to be really difficult to retain hyperlinks.

The only part of the subaddress that really matters is the SlideID and this is always unique in a given presentation. The problem comes when you add slides from elsewhere because the "unique" ID exists in that file as well. Got to keep the ID's unique so PPT changes the ID of the added slide and messes up the hyperlink. We have written solutions to this but it's not simple.

Basically scan the file to be added and add tags to each slide with the current ID
Add the slides
Scan the added slides for links and use the tags to locate the original ID and use it to remake the link with the new ID.

How to add tags

For Each osld In ActivePresentation.Slides
osld.Tags.Add "SID", (osld.SlideID)
Next osld

How to read tags

For Each osld In ActivePresentation.Slides
Debug.Print osld.tags("SID")
Next osld

[Bufger]

Many thanks John. I think i'll try and do the hyperlinks once its collated as there is alot of room for error with this.

You've been a great help. The project is looking very good and this has taken a good chunk of time out of my Mondays every week! Thanks