Automatic table of contents PowerPoint 2013

Hi,

I'm looking at the thing

See you later

Re,

bold line for index slide

 'loop through all slides starting from the 2nd
 For y = 2 To ActivePresentation.Slides.Count
 Set Diapo = ActivePresentation.Slides(y)
 'if the slide has a title
 If Diapo.Shapes.HasTitle Then
 Set titre = Diapo.Shapes.Title
 text_add = text_add & Format(y, "00 ") & titre.TextFrame.TextRange.Text & Chr(13)
 End If
 Next y

merci pour vos réponses,

J'ai cependant un souci car j'ai plusieurs titres qui sont identiques sur certaines diapositives, et j'aimerais que lorsque le titre de la diapositive N est identique à celui de la diapositive N-1, il n'y ait pas de ligne rajoutée dans le sommaire, et que cela rajoute juste un intervalle de page (type "p.6 - 10)

Voici le code que j'ai fait avec une pagination qui fonctionne, auriez-vous des solutions à ce problème ?

merci beaucoup !!

Sub sommaire()

Dim Diapo As Slide
Dim titre As Shape
Dim texte_ajout As TextRange
Dim texte_sommaire As TextRange
Dim ligne_sommaire As TextRange
Dim y As Byte

' ajoute une diapo en début de présentation avec
'la disposition de mise en titre n°2 du masque
ActivePresentation.Slides.Add Index:=1, Layout:=ppLayoutText
With ActivePresentation.Slides(1)
.Shapes(1).TextFrame.TextRange = "Sommaire"
Set texte_ajout = .Shapes(2).TextFrame.TextRange
End With

'boucle sur toutes les diapos à partir de la 2e
For y = 2 To 23
Set Diapo = ActivePresentation.Slides(y)
'si la diapo a un titre
If Diapo.Shapes.HasTitle Then
Set titre = Diapo.Shapes.Title
If y > 2 And titre.TextFrame.TextRange.Text = ActivePresentation.Slides(y - 1).Shapes.Title.TextFrame.TextRange.Text Then
texte_ajout.Text = texte_ajout.Text & " - " & Diapo.SlideNumber
Else
texte_ajout = texte_ajout & titre.TextFrame.TextRange.Text & " (p." & Diapo.SlideNumber & ")" & Chr(13)
End If
End If
Next y

'ajout de liens aux items du sommaire
Set texte_sommaire = _
ActivePresentation.Slides(1).Shapes(2).TextFrame.TextRange

'création liens hypertextes vers les titres
'si vous n'en souhaitez pas supprimez les paragraphes ci dessous

For y = 2 To 23
Set Diapo = ActivePresentation.Slides(y)
If Diapo.Shapes.HasTitle Then
Set titre = Diapo.Shapes.Title
texte = titre.TextFrame.TextRange.Text
Set ligne_sommaire = texte_sommaire.Find(FindWhat:=texte)
With ligne_sommaire
.ActionSettings(ppMouseClick).Hyperlink.SubAddress = _
Diapo.SlideID & "," & Diapo.SlideIndex & "," & texte
End With
End If
Next

Thank you very much, it works (almost) wonderfully, except for a small pagination problem when the titles are identical, it displays this:

Accounting Manual (p.2)
1. Introduction (p.5)
2. Definitions (p.6)
3. Group accounting policies (p.7 - 8)

(p.9 - 16)
4. Profit and loss account (p.17)
4.1 Income (p.18)
4.1.1.1 Products (p.19)
4.1.1.2 Non-Recurring Engineering (p.20 - 23)

Could this be related to the fact that the titles do not have the same format? (size for example)

Thank you very much !!

Re,

I don't know, at my place, no problem, I took a random file and it's fine. We would need your file with only the slides that have the titles if there is any confidential information.

Hello,

Indeed, this problem seems to be resolved!
I am now having difficulties formatting this summary!
I would like the pagination to appear at the end of the sentence and be right-aligned, and also to add a tab for the sub-sections and sub-sub-sections, like this:

1. Introduction p.3
2. XX p.4
3. Accounting principles p.5
3.1 Accounting principles sub part 1 p.6
3.1.1 Accounting principles sub sub part 1 p.7

I already have an idea for the tabs; I think we could manage with
if there is 1 digit, no tab
if there are 2 digits in the title, 1 tab, etc.

but I can't get it to work with the VBA syntax! I also can't integrate all the slides into the summary! I tried "from 3 to Activepresentation.slides.count" in the loop, but PowerPoint crashes when I run the macro :(

here is my code:

Sub sommaire()

Dim Diapo As Slide, Diapo1 As Slide
Dim titre As Shape
Dim texte_ajout As TextRange
Dim texte_sommaire As TextRange
Dim ligne_sommaire As TextRange
Dim y As Byte

'If the title of the first slide is "Summary", it will be deleted
'this allows the macro to be rerun as many times as desired
'without having to delete the summary slide
If ActivePresentation.Slides(1).Shapes(1).TextFrame.TextRange = "Sommaire" Then
ActivePresentation.Slides(1).Delete
End If

' add a slide at the beginning of the presentation with
'the title layout no. 2 of the master
ActivePresentation.Slides.Add Index:=1, Layout:=ppLayoutText
With ActivePresentation.Slides(1)
.Shapes(1).TextFrame.TextRange = "Sommaire"
Set texte_ajout = .Shapes(2).TextFrame.TextRange
End With

On Error Resume Next

'loop through all slides starting from the 2nd
For y = 3 To 23

Set Diapo = ActivePresentation.Slides(y)
Set Diapo1 = ActivePresentation.Slides(y + 1)

'if the slide has a title
If Diapo.Shapes.HasTitle Then
Set titre = Diapo.Shapes.Title
Set titre1 = Diapo1.Shapes.Title
If titre.TextFrame.TextRange.Text <> titre1.TextFrame.TextRange.Text Then
texte_ajout = texte_ajout & titre.TextFrame.TextRange.Text & " (p." & Diapo.SlideNumber & ")" & Chr(13)
Else
prem = Diapo.SlideNumber
Cmpt = prem
Do While titre.TextFrame.TextRange.Text = titre1.TextFrame.TextRange.Text
Cmpt = Cmpt + 1
Set Diapo1 = ActivePresentation.Slides(Cmpt)
Set titre1 = Diapo1.Shapes.Title

Loop
texte_ajout = texte_ajout & titre.TextFrame.TextRange.Text & " (p." & prem & " - " & Cmpt - 1 & ")" & Chr(13)
y = Cmpt - 1
End If
End If
Next y
'adding links to items in the summary
Set texte_sommaire = ActivePresentation.Slides(1).Shapes(2).TextFrame.TextRange

'creating hyperlinks to the titles
'if you don't want them, delete the paragraphs below
For y = 3 To 23
Set Diapo = ActivePresentation.Slides(y)
If Diapo.Shapes.HasTitle Then
Set titre = Diapo.Shapes.Title
texte = titre.TextFrame.TextRange.Text
Set ligne_sommaire = texte_sommaire.Find(FindWhat:=texte)
With ligne_sommaire
.ActionSettings(ppMouseClick).Hyperlink.SubAddress = _
Diapo.SlideID & "," & Diapo.SlideIndex & "," & texte
End With
End If
Next

End Sub

Is there a way to send files via this platform?

thank you in advance!!

Hello,

To make a file available, click on the following link: https://www.cjoint.com/

Don't forget to copy/paste the created link in your next message

See you!

thank you!

here is the link:

https://www.cjoint.com/?DGkjSeLOR0a

thank you very much!

Hi,

I’ll get your file and keep you updated.

See you!

Hi,

file with tab function title. If possible set tab to 3 or 4 characters, that's fine. We'll see. Problem with the second slide and the last two !!!!!!!!!!!!!!!!!

https://www.cjoint.com/c/DGklS6KLQyX

for page number framing, I’m waiting for your feedback on the file.

Hello,

it should be fine, I have removed the summary if present to avoid the multiplication of summaries

Sub summarySophie_Grml()
 Dim Slide As Slide, Slide1 As Slide
 Dim title As Shape
 Dim text_to_add As TextRange
 Dim summary_text As TextRange
 Dim summary_line As TextRange
 Dim y As Byte
 
 'If the title of the first slide is "Summary", it will be deleted
 'this allows the macro to be run as many times as desired
 'without having to delete the summary slide
 If ActivePresentation.Slides(1).Shapes(1).TextFrame.TextRange = "Summary" Then
 ActivePresentation.Slides(1).Delete
 End If

 ' add a slide at the beginning of the presentation with
 'the title layout n°2 of the master
 ActivePresentation.Slides.Add Index:=1, Layout:=ppLayoutText
 With ActivePresentation.Slides(1)
 .Shapes(1).TextFrame.TextRange = "Summary"
 Set text_to_add = .Shapes(2).TextFrame.TextRange
 End With

 On Error Resume Next

 'loop through all slides starting from the 2nd
 For y = 2 To 23
 Set Slide = ActivePresentation.Slides(y)
 Set Slide1 = ActivePresentation.Slides(y + 1)
 
 'if the slide has a title
 If Slide.Shapes.HasTitle Then
 Set title = Slide.Shapes.Title
 Set title1 = Slide1.Shapes.Title
 If title.TextFrame.TextRange.Text <> title1.TextFrame.TextRange.Text Then
 text_to_add = text_to_add & title.TextFrame.TextRange.Text & " (p." & Slide.SlideNumber & ")" & Chr(13)
 Else
 first = Slide.SlideNumber
 Count = first
 Do While title.TextFrame.TextRange.Text = title1.TextFrame.TextRange.Text
 Count = Count + 1
 Set Slide1 = ActivePresentation.Slides(Count)
 Set title1 = Slide1.Shapes.Title
 Loop
 text_to_add = text_to_add & title.TextFrame.TextRange.Text & " (p." & first & " - " & Count - 1 & ")" & Chr(13)
 y = Count - 1
 End If
 End If
 Next y
 'adding links to summary items
 Set summary_text = ActivePresentation.Slides(1).Shapes(2).TextFrame.TextRange

 'creating hyperlinks to the titles
 'if you don’t want them, remove the paragraphs below
 For y = 2 To 23
 Set Slide = ActivePresentation.Slides(y)
 If Slide.Shapes.HasTitle Then
 Set title = Slide.Shapes.Title
 text = title.TextFrame.TextRange.Text
 Set summary_line = summary_text.Find(FindWhat:=text)
 With summary_line
 .ActionSettings(ppMouseClick).Hyperlink.SubAddress = _
 Slide.SlideID & "," & Slide.SlideIndex & "," & text
 End With
 End If
 Next
End Sub

Hello,

http://fr.viadeo.com/fr/groups/detaildiscussion/?containerId=0021el8i9qpyom60&forumId=0022kc3dpxpaoo2&action=messageDetail&messageId=002umvaexyixkxo