1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107
|
Public Sub sommaire()
' déclaration des variables
Dim sld As Slide
Dim titreSlide As String
Dim sldPrecedente As Slide
Dim titreSlidePrecedente As String
Dim shp As Shape
Dim titreSlideSommaire As Shape
Dim numDiapo As Shape
Dim strTable As String
Dim strNumDiapo As String
Dim rgeSommaire As TextRange
Dim i As Integer
Dim countTitre As Integer
Dim titre As String
Dim positionParenthese As Integer
countTitre = 0
' on parcourt les diapos pour récupérer les informations des titres
For i = 2 To ActivePresentation.Slides.Count
Set sld = ActivePresentation.Slides(i)
Set sldPrecedente = ActivePresentation.Slides(i - 1)
' on test s'il y a une zone de titre
If (sld.Shapes.HasTitle And sldPrecedente.Shapes.HasTitle) Then
titreSlide = sld.Shapes.Title.TextFrame.TextRange.Text
titreSlidePrecedente = sldPrecedente.Shapes.Title.TextFrame.TextRange.Text
' on enlève tout ce qui contient des parenthèses
positionParenthese = InStr(1, titreSlide, " (")
If (positionParenthese > 0) Then
titreSlide = Left(titreSlide, positionParenthese - 1)
End If
positionParenthese = InStr(1, titreSlidePrecedente, " (")
If (positionParenthese > 0) Then
titreSlidePrecedente = Left(titreSlidePrecedente, positionParenthese - 1)
End If
' on ajoute que celle qui ont un titre différent de la précédente
If (titreSlide <> titreSlidePrecedente) Then
countTitre = countTitre + 1
If (countTitre > 1) Then
' on fait un saut de ligne à la troisième diapo parcourue
strTable = strTable & vbCrLf
strNumDiapo = strNumDiapo & vbCrLf
End If
' s'il s'agit d'un sous titre, on met une tabulation
If (sld.Shapes.Title.TextFrame.TextRange.Characters.Font.Size <= 28) Then
strTable = strTable & vbTab
End If
' on enlève les retours à la ligne dans le titre
titreSlide = Replace(titreSlide, "", " - ") ' petit carré que je ne peux copier
' si le titre ou sous-titre dépasse 50 caractères, il va être mis automatiquement à la ligne
' il faut donc sauter une ligne dans le shape de numéro de diapo
' et donc augmenter le nombre de titres comptabilisés
If (Len(titreSlide) > 50) Then
strNumDiapo = strNumDiapo & vbCrLf
countTitre = countTitre + 1
End If
strTable = strTable & titreSlide
strNumDiapo = strNumDiapo & i
End If
End If
' on met dans un nouveau slide les 13 titres
If (countTitre = 13) Then
' on va ajouter le sommaire à la première diapo
Set sld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutBlank)
Set titreSlideSommaire = sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 200, 20, 400, ActivePresentation.PageSetup.SlideHeight / 2)
Set shp = sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 100, 600, ActivePresentation.PageSetup.SlideHeight / 2)
' on créé un cadre en plus pour mettre les numéro de diapo
Set numDiapo = sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 650, 100, 100, ActivePresentation.PageSetup.SlideHeight / 2)
shp.TextFrame.TextRange.Text = strTable
shp.TextFrame.TextRange.Font.Size = 24
numDiapo.TextFrame.TextRange.Text = strNumDiapo
numDiapo.TextFrame.TextRange.Font.Size = 24
titreSlideSommaire.TextFrame.TextRange.Text = "Sommaire"
titreSlideSommaire.TextFrame.TextRange.Font.Size = 28
titreSlideSommaire.TextFrame.TextRange.Font.Color.RGB = RGB(128, 128, 128)
countTitre = 0
strTable = ""
strNumDiapo = ""
End If
Next i
End Sub |
Partager