PowerPoint2013,2016…スライドに目次を挿入するマクロ（上級者向き）

by denkineko · 公開済み 2017年5月10日 · 更新済み 2020年8月28日

PowerPontで枚数の多いスライドを作成すると目次を入れたくなりますが、PowerPontにはWordのような目次挿入機能はありません。「無いのなら、作ってしまえ目次挿入！」と言うことで、目次挿入マクロを作成しました。

ファイル > オプション > リボンのユーザー設定 > 開発にチェックを入れて、開発タブを表示します。（マクロの作成準備）
BIsual Basic > 挿入 > 標準モジュールでコードペインが表示されたら、以下のvbaのコードを貼り付けます。

※このままでも動きますが、インデントは適当に付けてください。

‘——————————————開始—————————————-
‘戻り値セット

Dim Rtn As Integer

Sub 目次の挿入()

On Error GoTo ERR_HANDLER

Dim objSlide As Slide
Dim objText As TextRange
Dim objShape As Shape
Dim intId As Integer
Dim idxFlag As Integer
Dim intPage As Integer
Dim intNone As Integer
Dim intLoop As Integer

‘アクティブなスライドのSlideIndexを取得
intId = ActiveWindow.Selection.SlideRange.SlideIndex

‘アクティブなスライドの前に、目次用スライドを追加
ActivePresentation.Slides.Add intId, ppLayoutText
ActivePresentation.Slides(intId).Shapes(1).TextFrame.TextRange = “目次”

‘今、追加した目次用スライドに、各スライドのタイトルを書き出す
Set objText = ActivePresentation.Slides(intId).Shapes(2).TextFrame.TextRange
objText = “”

idxFlag = 0
intPage = 0
intNone = 0
For Each objSlide In ActivePresentation.Slides
‘タイトルプレースホルダがある場合
If objSlide.Shapes.HasTitle Then
Set objShape = objSlide.Shapes.Title
‘タイトルが入力されている場合
If Trim(objShape.TextFrame.TextRange.Text) <> “” Then
objText = objText & objShape.TextFrame.TextRange.Text
‘タイトルが目次の場合、フラグをセット
If Trim(objShape.TextFrame.TextRange.Text) = “目次” Then
idxFlag = 1
End If
‘タイトルが未入力かスペースだけの場合
Else
objText = objText & “（タイトルなし）”
End If
‘タイトルプレースホルダがない場合
Else
objText = objText & “（タイトルなし）”
End If
If idxFlag <> 0 And objText <> “目次” Then
‘ページ数カウント
intPage = intPage + 1
objText = objText & “・・・・・ ” & intPage & Chr(13)
Else
‘表紙＋目次ページ数カウント
intNone = intNone + 1
objText = “”
End If
Next objSlide

‘リンクの設定
For intLoop = 1 To objText.Sentences.Count
Set objSlide = ActivePresentation.Slides(intLoop + intNone)
With objText.Sentences(intLoop).ActionSettings(ppMouseClick).Hyperlink
‘リンク先スライドの指定
.SubAddress = _
objSlide.SlideID & “,” & _
objSlide.SlideIndex & “,” & _
objText.Sentences(intLoop).Text
‘ポップヒントの指定
‘ .ScreenTip = objText.Sentences(intLoop).Text
End With
Next intLoop

Exit Sub

ERR_HANDLER:

MsgBox “スライドを1枚だけ選択してから、マクロを実行してください。”

End Sub

Sub 目次の削除()

Dim objSlide As Slide
Dim objText As TextRange
Dim objShape As Shape
Dim intPage As Integer
Dim delFlag As Integer

intPage = 0
delFlag = 0
For Each objSlide In ActivePresentation.Slides
intPage = intPage + 1
If objSlide.Shapes.HasTitle Then
Set objShape = objSlide.Shapes.Title
‘タイトルが入力されている場合
If Trim(objShape.TextFrame.TextRange.Text) = “目次” Then
‘目次用スライドを削除
ActivePresentation.Slides.Item(intPage).Delete
delFlag = 1
End If
End If
Next objSlide

If delFlag = 0 Then
MsgBox “目次スライドが見つかりません。”
Rtn = 1
End If

End Sub

Sub 目次の再作成()

Rtn = 0
Call 目次の削除
If Rtn = 0 Then
Call 目次の挿入
End If

End Sub

Sub セクション名の追加()

Dim intId As Integer
Dim objSlide As Slide

‘アクティブなスライドのSlideIndexを取得
intId = ActiveWindow.Selection.SlideRange.SlideIndex

For Each objSlide In ActivePresentation.Slides
ActivePresentation.Slides(intId).HeadersFooters.Footer.Text = “セクション”
Next objSlide

End Sub
‘——————————————終了—————————————-