[PowerPoint]目次を自動生成する方法

パワーポイント TIPS
パワーポイント

PowerPointには、Wordのようにボタン一つで目次を自動生成する標準機能はありません。しかし、VBA（マクロ）やPythonスクリプトを利用することで、各スライドのタイトルを抽出して目次ページを自動で作成することが可能です。

実行手順

  1. VBAエディタを開く
    • 目次を生成したいPowerPointファイルを開きます。
    • キーボードで Alt + F11 を押して、VBAエディタを開きます。
  2. モジュールの挿入
    • VBAエディタのメニューバーから「挿入」→「標準モジュール」を選択します。
  3. コードの貼り付け
    • 表示された白い画面（コードウィンドウ）に、後述のVBAコードをそのままコピー＆ペーストします。
  4. マクロの実行
    • VBAエディタのメニューバーから「実行」→「Sub/ユーザーフォームの実行」（またはキーボードで F5）を押します。
  5. 完了
    • プレゼンテーションの2ページ目に、各スライドのタイトルとページ番号が記載され、クリックするとそのページにジャンプできる目次スライドが自動で作成・更新されます。
Sub CreateTableOfContents()
    ' === 設定項目 ===
    Const TOC_SLIDE_INDEX As Integer = 2 ' 目次を挿入するスライド番号 (2ページ目)
    Const TOC_TITLE As String = "目次"     ' 目次スライドのタイトル
    ' ================

    Dim ppt As Presentation
    Set ppt = ActivePresentation

    Dim tocSlide As Slide
    Dim targetShape As Shape
    Dim s As Slide
    Dim i As Integer

    ' --- 既存の目次スライドがあれば削除 ---
    On Error Resume Next ' スライドが存在しない場合のエラーを無視
    ppt.Slides("p_toc_slide").Delete
    On Error GoTo 0

    ' --- 新しい目次スライドを挿入 ---
    Set tocSlide = ppt.Slides.Add(TOC_SLIDE_INDEX, ppLayoutTitleOnly)
    tocSlide.Name = "p_toc_slide" ' 識別用の名前を付ける
    tocSlide.Shapes.Title.TextFrame.TextRange.Text = TOC_TITLE

    ' --- 目次を書き込むテキストボックスを作成 ---
    Set targetShape = tocSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 1 * 72, 1.5 * 72, 14 * 72, 7 * 72)
    
    With targetShape.TextFrame
        .MarginBottom = 0
        .MarginLeft = 0
        .MarginRight = 0
        .MarginTop = 0
        .WordWrap = msoTrue
        With .TextRange.Font
            .Name = "メイリオ" ' フォントを指定
            .Size = 18         ' フォントサイズを指定
        End With
    End With

    ' --- 各スライドのタイトルをループで取得し、目次に追記 ---
    For i = 1 To ppt.Slides.Count
        Set s = ppt.Slides(i)
        
        ' 自分自身（目次スライド）は除外
        If s.SlideIndex <> TOC_SLIDE_INDEX Then
            ' スライドにタイトルが存在する場合のみ処理
            If s.Shapes.HasTitle Then
                If s.Shapes.Title.TextFrame.HasText Then
                    Dim titleText As String
                    titleText = s.Shapes.Title.TextFrame.TextRange.Text
                    
                    Dim newPara As TextRange
                    ' テキストボックスの末尾に「タイトル タブ ページ番号 改行」を追加
                    Set newPara = targetShape.TextFrame.TextRange.InsertAfter(titleText & vbTab & s.SlideNumber & vbCrLf)
                    
                    ' ハイパーリンクを設定（追加したテキスト全体ではなく、その段落に設定）
                    Dim paraToLink As TextRange
                    Set paraToLink = targetShape.TextFrame.TextRange.Paragraphs(targetShape.TextFrame.TextRange.Paragraphs.Count - 1)
                    
                    With paraToLink.ActionSettings(ppMouseClick)
                        .Action = ppActionHyperlink
                        .Hyperlink.SubAddress = s.SlideID & "," & s.SlideIndex & "," & titleText
                    End With
                End If
            End If
        End If
    Next i
    
    ' 最後に余分な改行を削除
    If targetShape.TextFrame.TextRange.Characters.Count > 1 Then
        targetShape.TextFrame.TextRange.Characters(targetShape.TextFrame.TextRange.Characters.Count, 1).Delete
    End If
    
    MsgBox "目次が作成・更新されました。"
End Sub

コメント

タイトルとURLをコピーしました