PowerPoint VBAを掌握する極限の知見：CreateVideoの罠と全スライド4K動画一括エクスポートの極意
プロフェッショナルな現場において、PowerPointを単なる「画面上のプレゼンツール」として扱う時代は終わった。デジタルサイネージ、Webプロモーション、あるいは自動化された動画コンテンツの量産パイプラインにおいて、PowerPointの描画エンジンをヘッドレスに制御し、最高画質の動画（.mp4）として一括吐き出しするスキルは、自動化エンジニアにとって強力な武器となる。
しかし、ここで多くの開発者が絶望する。
PowerPoint VBAにおける `CreateVideo` メソッドは、公式ドキュメントの記述だけを信じて実装すると、「非同期処理のブラックボックス」「謎のハングアップ」「極端な画質低下」「音声・タイミングのズレ」という泥沼に引きずり込まれるからだ。
今回は、数々の修羅場をくぐり抜けてきたアーキテクトの視点から、`CreateVideo` の挙動を完全に手なずけ、フルHD/4K動画を堅牢に出力するためのプロダクションコードと設計思想を伝授する。
—
なぜ素人のコードは失敗するのか？（非同期処理の呪縛）
多くのプログラマが最初に直面する壁、それは `CreateVideo` が「非同期（バックグラウンド）で実行される」という事実を見落としていることだ。
VBAの通常のメソッドは、処理が完了するまで制御を次の行に渡さない（同期処理）。しかし、`CreateVideo` は違う。メソッドを呼び出した瞬間、PowerPointは別スレッド（あるいは内部キュー）でエンコードを開始し、VBA側は平然と次の処理（あるいは終了処理）へ進んでしまう。
もし、この仕様を理解せずに「動画を出力した直後にファイルを閉じる」「次のプレゼンを開いて連続で動画化する」というマクロを書けばどうなるか？
出力途中のファイルが強制終了され、0バイトのゴミファイルが生成されるか、最悪の場合はPowerPointプロセスそのものがクラッシュする。
堅牢な設計の要諦
1. エンコード完了のポーリング監視：`CreateVideoStatus` プロパティを監視し、ステータスが「完了（ppMediaEncodingDone）」または「失敗（ppMediaEncodingFailed）」になるまでVBAの実行をループでウェイトさせなければならない。
2. タイムアウト機構の実装：巨大な4Kスライドや複雑なアニメーションを含むファイルは、エンコードに膨大な時間を要する。無限ループに陥った際のフェイルセーフとして、必ずタイムアウトタイマーを組み込むこと。
3. 適切なスライドタイミング（`SlideShowTransition.AdvanceTime`）の担保：動画化の際、各スライドが何秒表示されるかは、手動クリックではなく「自動切り替え時間」に依存する。VBA側でこれを一括制御する必要がある。
—
プロダクションコード：全スライドを4K/フルHD動画へ完璧に変換するVBA
実務でそのまま導入できる、エラーハンドリングと進捗監視を完璧に実装したモジュールを提供する。このコードは、アクティブなプレゼンテーションを指定した解像度・フレームレート・秒数で.mp4出力するものだ。
Option Explicit
‘ ==============================================================================
‘ モジュール名: MdlVideoExporter
‘ 概要 : プレゼンテーションを最高画質（4K/フルHD）のMP4動画へ非同期制御で
‘ 確実に出力するためのプロダクションコード
‘ ==============================================================================
Public Sub ExportPresentationToVideo()
Dim targetPres As Presentation
Set targetPres = ActivePresentation
‘ 出力先パスの動的生成（同一フォルダ内に「動画」フォルダを作成）
Dim outputPath As String
outputPath = GetValidOutputPath(targetPres, “mp4”)
If outputPath = “” Then Exit Sub
‘ — 設定パラメータ（要件に合わせて変更） —
Const TARGET_WIDTH As Long = 3840 ‘ 3840 for 4K, 1920 for Full HD
Const TARGET_HEIGHT As Long = 2160 ‘ 2160 for 4K, 1080 for Full HD
Const FRAMES_PER_SECOND As Long = 60 ‘ 滑らかな動きが必要なら60fps
Const DEFAULT_SLIDE_SEC As Long = 5 ‘ 各スライドのデフォルト表示秒数
Const MAX_TIMEOUT_SEC As Long = 1800 ‘ タイムアウト制限（30分）
‘ ——————————————
‘ 1. スライドの切り替えタイミング（秒数）を全スライドに強制適用
Dim sld As Slide
For Each sld In targetPres.Slides
With sld.SlideShowTransition
.AdvanceOnTime = msoTrue
.AdvanceTime = DEFAULT_SLIDE_SEC
End With
Next sld
‘ 2. 動画生成の非同期リクエストを発行
On Error GoTo ErrorHandler
Debug.Print “【INFO】動画エンコードを開始します: ” & outputPath
targetPres.CreateVideo FileName:=outputPath, _
UseTimingsAndNarrations:=True, _
DefaultSlideDuration:=DEFAULT_SLIDE_SEC, _
VertResolution:=TARGET_HEIGHT, _
FramesPerSecond:=FRAMES_PER_SECOND, _
Quality:=100 ‘ 最高品質
‘ 3. 非同期処理の完了を監視するポーリングループ
Dim startTime As Double
startTime = Timer
Do While targetPres.CreateVideoStatus = ppMediaEncodingInProgress
‘ Excel/PPTのUIフリーズを防ぎつつCPU負荷を抑制
DoEvents
Application.Wait (Now + TimeValue(“0:00:01”))
‘ タイムアウト判定
If (Timer – startTime) > MAX_TIMEOUT_SEC Then
targetPres.StopVideoEncoding
Err.Raise 9999, “VideoExporter”, “動画エンコードがタイムアウトしました（制限: ” & MAX_TIMEOUT_SEC & “秒）”
End If
Loop
‘ 4. ステータスの最終確認
If targetPres.CreateVideoStatus = ppMediaEncodingDone Then
MsgBox “動画のエクスポートが正常に完了しました！” & vbCrLf & “保存先: ” & outputPath, vbInformation, “処理成功”
Else
Err.Raise 9998, “VideoExporter”, “動画エンコードに失敗しました。ステータスコード: ” & targetPres.CreateVideoStatus
End If
CleanUp:
Exit Sub
ErrorHandler:
MsgBox “致命的なエラーが発生しました [” & Err.Number & “]: ” & Err.Description, vbCritical, “エラー”
Resume CleanUp
End Sub
‘ ==============================================================================
‘ 補助関数: 上書き確認と出力パスの生成
‘ ==============================================================================
Private Function GetValidOutputPath(pres As Presentation, ext As String) As String
Dim fso As Object
Set fso = CreateObject(“Scripting.FileSystemObject”)
If pres.Path = “” Then
MsgBox “このプレゼンテーションはまだ保存されていません。一度保存してから実行してください。”, vbExclamation
GetValidOutputPath = “”
Exit Function
End If
Dim baseName As String
baseName = fso.GetBaseName(pres.Name)
Dim dirPath As String
dirPath = pres.Path & “\VideoOutput”
If Not fso.FolderExists(dirPath) Then
fso.CreateFolder (dirPath)
End If
Dim fullPath As String
fullPath = dirPath & “\” & baseName & “_” & Format(Now, “yyyymmdd_hhnnss”) & “.” & ext
GetValidOutputPath = fullPath
End Function
—
コードの急所：エンジニアが押おくべき3つのポイント
1. `Quality` パラメータと解像度のトレードオフ
コード内では `Quality:=100` を指定している。これはビットレートを最大化し、グラデーションのバンディング（色階調の破綻）を防ぐためのプロフェッショナルとしての必須設定だ。
ただし、`VertResolution:=2160`（4K）と `Quality:=100` の組み合わせは、生成されるファイルサイズが爆発的に増大する。もし社内共有や軽量なWeb配信用であれば、`VertResolution:=1080`（フルHD）に落とすのが実務上は無難である。
2. `DoEvents` と `Application.Wait` の調律
ポーリング監視ループ内において、`DoEvents` だけを回すとCPU使用率が100%に張り付いてマシーントラブルを引き起こす。かといって `Application.Wait` で長く止めすぎると、VBAの応答性が悪くなる。
上記コードのように `DoEvents` でイベントを処理しつつ、1秒のインターバル（`Application.Wait (Now + TimeValue(“0:00:01”))`）を挟むのが、バックグラウンドプロセスの監視において最もCPUに優しく確実な手法である。
3. バッチ処理（複数ファイルの一括変換）への拡張性
今回のコードは単一のプレゼンテーションを対象としているが、実務では「指定フォルダ内の全 `.pptx` を読み込んで順次4K動画化する」というバッチ処理が求められるだろう。
その場合、親となる controladores（制御用マクロ）から `Presentations.Open` でファイルをサイレントオープンし、上記のロジックを関数として呼び出して `Close` する構造にリファクタリングすればよい。その際、必ず `DisplayAlerts = False` を設定し、余計なダイアログで処理がストップするのを防ぐこと。
—
アーキテクトからの総括
PowerPointの動画エクスポート機能は、GUIから操作すると進捗状況が分かりにくく、巨大なファイルではフリーズしたように見えてフラが溜まる。しかし、VBAを用いて `CreateVideoStatus` を明示的に監視するアーキテクチャを構築すれば、完全に予測可能で安定した「自動動画生成パイプライン」へと昇華させることができる。
「動けばいい」という妥協を捨て、非同期のライフサイクルを完全に制御した堅牢なコードこそが、プロのエンジニアの成果物である。ぜひ自身の開発環境に組み込み、その圧倒的な安定性を体感してほしい。
