PowerPointサムネイル作成を完全自動化！ワンクリックでPNG出力する時短マクロ術

以前、PowerPointで日付を自動更新する方法をご紹介しました。
PowerPointで「日付を自動更新」する方法｜VBAでサクッと！

日付の自動更新っすね。

あの記事では「日付の自動更新」だけでしたが、実際に毎日使っていると「もっと自動化できるんじゃないか？」と思うようになりました。

日付を更新した後って、結局こんな作業が待ってるんですよね：

スライドを選択
「名前を付けて保存」でPNG形式を選択
ファイル名を手動で入力
保存先フォルダを毎回選択
解像度の設定

さらに、サムネイルの要約欄も毎回手動でフォーマット設定していました：

フォントを「Noto Sans JP」に変更
太字に設定
文字色を白に変更

今度は要約欄だって、こだわりがあったりして。笑

特に私は毎日3種類のニュースまとめ記事用のサムネイルを作成しているので、この手順を毎日3回繰り返すのが正直めんどくさくて…😅

AIニュースまとめ
暮らしとお金のニュースまとめ
世界のマネーニュースまとめ

そこで今回は、前回の「日付自動更新」をさらにブラッシュアップして、日付更新・フォーマット整形・PNG出力まで全てを一発で完了する完全自動化マクロを作成しました！

つまり、ワンクリックで：

✅ 日付の自動更新
✅ 要約欄のフォント・太字・色の自動整形
✅ PNG形式での保存
✅ ファイル名の自動生成
✅ 保存先フォルダの自動振り分け
✅ 1920×1080の高解像度出力
✅ 既存ファイルの上書き確認

これら全てが完了します。

そんなところを解決するのが、チャチャのテックハックの出番です！

というわけで

こんばんは、チャチャです😺

今回は、PowerPointでのサムネイル作成を完全自動化するマクロをご紹介します！

🚀 解決策：完全自動化マクロ
1. 実現できること
📝 完全版マクロコード
🔧 セットアップ方法
💡 使用方法
📊 効果測定
🎉 まとめ

🚀 解決策：完全自動化マクロ

そこで作成したのが、ワンクリックで日付更新・フォーマット整形・PNG出力まで完了するマクロです。

実現できること

✅ 全スライドの日付を今日の日付に自動更新
✅ 要約欄のフォント・太字・色を自動整形
✅ 選択したスライドのみを処理
✅ スライドごとに異なるフォルダに自動保存
✅ ファイル名も自動生成（例：AI_20250606.png）
✅ 1920×1080の高解像度で出力
✅ 既存ファイルの上書き確認

📝 完全版マクロコード

Sub AutoUpdateAndExportSlide()
    ' 日付を自動更新
    Call AutoUpdateDate
    
    ' 概要フォーマット整形
    Call FormatAllMySummaryBox
    
    Dim ppt As Presentation
    Dim slide As slide
    Dim dateStr As String
    Dim basePath As String
    Dim fileName As String
    Dim fullPath As String
    Dim slideIndex As Integer
    
    ' アクティブなプレゼンテーションを取得
    Set ppt = ActivePresentation
    
    ' 現在選択されているスライドのインデックスを取得
    slideIndex = ActiveWindow.Selection.SlideRange.slideIndex
    Set slide = ppt.Slides(slideIndex)
    
    ' 更新された日付を取得して変換（現在の日付を使用）
    dateStr = Format(Date, "yyyymmdd")
    
    ' ベースパスを設定
    basePath = "チャチャが普段使ってるフォルダパス\01.サムネイル\"
    
    ' 選択されたスライドに応じてパスとファイル名を設定
    Select Case slideIndex
        Case 1
            ' AIニュースまとめ
            fullPath = basePath & "01.AIニュース\"
            fileName = "AI_" & dateStr & ".png"
            
        Case 2
            ' 暮らしとお金のニュースまとめ
            fullPath = basePath & "02.国内お金くらし\"
            fileName = "国内_" & dateStr & ".png"
            
        Case 3
            ' 世界のマネーニュースまとめ
            fullPath = basePath & "03.世界マネー\"
            fileName = "世界_" & dateStr & ".png"
            
        Case Else
            MsgBox "対応していないスライドです。1-3枚目のスライドを選択してください。", vbExclamation
            Exit Sub
    End Select
    
    ' フォルダが存在しない場合は作成
    If Dir(fullPath, vbDirectory) = "" Then
        CreateFolder fullPath
    End If
    
    ' ファイル存在チェック
    If Dir(fullPath & fileName) <> "" Then
        Dim response As VbMsgBoxResult
        response = MsgBox("ファイル「" & fileName & "」は既に存在します。" & vbCrLf & _
                         "上書きしますか？", vbYesNo + vbQuestion + vbDefaultButton2, "ファイル上書き確認")
        
        If response = vbNo Then
            MsgBox "出力をキャンセルしました。", vbInformation
            Exit Sub
        End If
    End If
    
    ' 1920x1080の解像度でPNG出力
    slide.Export fullPath & fileName, "PNG", 1920, 1080
    
    ' 出力完了メッセージ
    MsgBox "日付更新＆スライド" & slideIndex & "の出力が完了しました（1920x1080）。" & vbCrLf & _
           "更新日付: " & Format(Date, "yyyy年mm月dd日") & vbCrLf & _
           "保存先: " & fullPath & fileName, vbInformation
End Sub

' 日付自動更新サブルーチン
Sub AutoUpdateDate()
    Dim sld As slide
    For Each sld In ActivePresentation.Slides
        On Error Resume Next
        sld.Shapes("myDateBox").TextFrame.TextRange.Text = Format(Date, "yyyy年mm月dd日")
        On Error GoTo 0
    Next sld
End Sub

' フォルダ作成サブルーチン
Sub CreateFolder(folderPath As String)
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    If Not fso.FolderExists(folderPath) Then
        fso.CreateFolder folderPath
    End If
End Sub

' 概要フォーマット整形サブルーチン
Sub FormatAllMySummaryBox()
    Dim sld As slide
    Dim shp As Shape
    Dim fontName As String
    fontName = "Noto Sans JP"
    
    For Each sld In ActivePresentation.Slides
        On Error Resume Next
        Set shp = sld.Shapes("mySummaryBox")
        With shp.TextFrame.TextRange.Font
            .Name = fontName
            .Bold = msoTrue
            .Color.RGB = RGB(255, 255, 255)
        End With
        On Error GoTo 0
    Next sld
End Sub

🔧 セットアップ方法

その前に^ ^

私の毎日のニュースまとめのサムネイルパワポは

１スライド目：AIニュースまとめ
２スライド目：暮らしとお金のニュースまとめ
３スライド目：世界のマネーニュースまとめ

となっており、ニュースごとに全部フォルダを切って管理したいのが私の要望です。
で、それぞれのサムネイルに固定文言＋日付で管理し、分かりやすくしたかったわけです。

1. 前提条件

PowerPointのスライドに「myDateBox」という名前のテキストボックスを配置（前回記事参照）

PowerPointのスライドに「mySummaryBox」という名前のテキストボックスを配置（要約欄用）

保存先フォルダのパスを環境に合わせて修正

チャチャの場合、以下にしてます。
１スライド目：AIニュースまとめ　→　01.AIニュース
２スライド目：暮らしとお金のニュースまとめ　→　02.国内お金くらし
３スライド目：世界のマネーニュースまとめ　→　03.世界マネー

' 選択されたスライドに応じてパスとファイル名を設定
Select Case slideIndex
    Case 1
        ' AIニュースまとめ
        fullPath = basePath & "01.AIニュース\"
        fileName = "AI_" & dateStr & ".png"
        
    Case 2
        ' 暮らしとお金のニュースまとめ
        fullPath = basePath & "02.国内お金くらし\"
        fileName = "国内_" & dateStr & ".png"
        
    Case 3
        ' 世界のマネーニュースまとめ
        fullPath = basePath & "03.世界マネー\"
        fileName = "世界_" & dateStr & ".png"
        
    Case Else
        MsgBox "対応していないスライドです。1-3枚目のスライドを選択してください。", vbExclamation
        Exit Sub
End Select