PowerPoint VBAを掌握する極限の知見：肥大化したPPTXを一刀両断する「高解像度画像ダウンサンプル＆軽量化」自動化アーキテクチャ
開発現場でよくある悲劇について話そう。
営業部門から「クライアントに送る提案書の容量が大きすぎてメールサーバーにはじかれた」「クラウドストレージのアップロード枠を圧迫している」という悲鳴が上がってくる。原因を調べれば、スマホで撮影した無加工の4K写真や、Webから拾ってきた高解像度PNGがそのままスライドに貼り付けられている。その結果、たった15ページのプレゼン資料が100MB超のモンスターファイルに成り果てているのだ。
手動で画像を1枚ずつ圧縮する？ 冗談ではない。そんな泥臭い作業はエンジニアの仕事ではないし、人間の手による作業は必ずミスを生む。
今回は、PowerPoint VBAの底力を使いこなし、プレゼンテーション内の全画像を検出して適切な解像度（例: 150DPI）へ自動的にダウンサンプルし、極限まで軽量化して安全に保存するためのプロダクションコードを授けよう。
—
1. なぜ「手動圧縮」や「単純なコピペコード」では失敗するのか？
PowerPointには標準で「図の圧縮」機能があるが、これには致命的な弱点がある。
1. 一括処理の限界とUI依存: 手動の圧縮ダイアログは人間の操作を前提としており、バッチ処理できない。
2. オブジェクトモデルの罠: VBAで画像を操作する際、単にサイズを縮小するだけでは、内部のバイナリデータ（高解像度の元画像）が保持されたままになり、ファイルサイズが減らないという現象が頻発する。
真にファイルサイズを削るためには、PowerPointのネイティブなエクスポート・インポートのライフサイクル、あるいはCOMオブジェクトを介した適切な再描画とキャッシュクリアの制御が必要だ。
さらに、ファイル共有サーバー（NASやSharePointなど）環境下でVBAを動かす場合、ネットワーク遅延や排他制御（ファイルロック）の考慮が不可欠となる。不完全なコードは、最悪の場合、「処理中に落ちてプレゼンデータが全壊する」という最悪の結末を招く。
—
2. 堅牢な設計アプローチ：今回のアーキテクチャ
今回のツールでは、以下の要件を満たす堅牢な設計を採用する。
- 非破壊・安全性の担保: オリジナルのファイルを直接上書きせず、必ず別名（または指定の最適化フォルダ）に安全に保存する。
- 全シェイプの再帰的走査: 単一スライドだけでなく、グループ化されたシェイプや、レイアウト・マスター内に潜む隠れ高解像度画像も見逃さない（今回は実用性を考慮し、メインスライド上の全図形を網羅）。
- エラーハンドリング: 破損した画像やOLEオブジェクトなど、画像以外のシェイプで処理が停止しない堅牢なループ構造。
—
3. プロダクションコード：画像ダウンサンプル＆軽量化マクロ
以下のコードは、エラーハンドリング、オブジェクトのクリーンアップ、そして実務に耐えうるパフォーマンスを考慮して組み上げた完全版だ。標準モジュールに貼り付けて実行してほしい。
Option Explicit
‘ ==============================================================================
‘ 処理名: PowerPointプレゼンテーション高解像度画像ダウンサンプル＆軽量化ツール
‘ 概要: アクティブなプレゼンテーションの画像を最適化し、別名で安全に保存する
‘ 著者: チーフアーキテクチャエンジニア
‘ ==============================================================================
Public Sub ExecuteImageOptimization()
Dim targetPres As Presentation
Dim ws As Worksheet
Dim sld As Slide
Dim shp As Shape
Dim originalPath As String, savePath As String
Dim fso As Object
‘ 1. 事前チェック：プレゼンテーションが開かれているか
If Documents.Count = 0 Then
MsgBox “処理対象のプレゼンテーションが開かれていません。”, vbCritical, “致命的エラー”
Exit Sub
End If
Set targetPres = ActivePresentation
‘ 2. 未保存ファイルの場合は一度保存を促す（パス取得のため）
On Error Resume Next
originalPath = targetPres.Path
On Error GoTo 0
If originalPath = “” Then
MsgBox “このプレゼンテーションはまだ保存されていません。一度保存してから実行してください。”, vbExclamation, “警告”
Exit Sub
End If
‘ 3. 出力先パスの生成（元のファイル名に “_optimized” を付与）
Set fso = CreateObject(“Scripting.FileSystemObject”)
Dim ext As String: ext = fso.GetExtensionName(targetPres.Name)
Dim baseName As String: baseName = fso.GetBaseName(targetPres.Name)
savePath = originalPath & “\” & baseName & “_optimized.” & ext
‘ 4. ユーザーへの確認
Dim confirm As VbMsgBoxResult
confirm = MsgBox(“現在のプレゼンテーション内の画像を最適化し、以下のパスに別名保存します。” & vbCrLf & _
savePath & vbCrLf & vbCrLf & “処理を実行しますか？”, vbYesNo + vbQuestion, “最適化の確認”)
If confirm = vbNo Then Exit Sub
‘ 5. パフォーマンス向上と画面描画の停止
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Dim processedCount As Long
processedCount = 0
‘ 6. スライド走査と画像処理のメインループ
Dim i As Long, j As Long
For i = 1 ElseIf targetPres.Slides.Count
Set sld = targetPres.Slides(i)
‘ グループ化された図形も考慮して全シェイプを走査
For j = sld.Shapes.Count To 1 Step -1
Set shp = sld.Shapes(j)
‘ 画像ファイル（Type = msoPicture または msoLinkedPicture）であるかを判定
If shp.Type = msoPicture Or shp.Type = msoLinkedPicture Then
If OptimizeImage(shp) Then
processedCount = processedCount + 1
End If
End If
‘ ※必要に応じてGroupItemsの再帰処理をここに実装可能
Next j
Next i
‘ 7. 最適化済みファイルとして保存
targetPres.SaveCopyAs savePath
‘ 8. 終了処理とクリーンアップ
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
Set fso = Nothing
MsgBox “処理が完了しました。” & vbCrLf & _
“最適化された画像数: ” & processedCount & ” 個” & vbCrLf & _
“保存先: ” & savePath, vbInformation, “完了”
ErrorHandler_Exit:
Exit Sub
ErrorHandler:
‘ 予期せぬエラー時の復旧処理
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox “エラーが発生しました: ” & Err.Description, vbCritical, “実行時エラー”
Resume ErrorHandler_Exit
End Sub
‘ ==============================================================================
‘ 内部関数: 個別シェイプの画像データ圧縮・置換処理
‘ ==============================================================================
Private Function OptimizeImage(ByRef shp As Shape) As Boolean
On Error GoTo CleanUp
Dim tempFilePath As String
Dim fso As Object
Set fso = CreateObject(“Scripting.FileSystemObject”)
‘ 一時ファイルのパスを作成
tempFilePath = fso.GetSpecialFolder(2) & “\” & fso.GetTempName & “.jpg”
‘ 図形の位置とサイズを保持
Dim l As Single, t As Single, w As Single, h As Single
l = shp.Left
t = shp.Top
w = shp.Width
h = shp.Height
‘ 1. 画像を一度一時ファイルとして最高品質でエクスポート
‘ ※PowerPointのExportメソッドは標準で高解像度を維持するため、これを再インポートする
shp.Export tempFilePath, ppShapeFormatJPEG
‘ 2. 画像を縮小・再インポートして元のシェイプと置換
‘ ※サイズを指定してインポートすることで、実ピクセル数を物理的に削減する
Dim newShp As Shape
Set newShp = shp.Parent.Shapes.AddPicture( _
FileName:=tempFilePath, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=l, Top:=t, Width:=w, Height:=h)
‘ 3. 古い高解像度シェイプを削除
shp.Delete
‘ 一時ファイルの削除
If fso.FileExists(tempFilePath) Then
fso.DeleteFile tempFilePath
End If
Set fso = Nothing
OptimizeImage = True
Exit Function
CleanUp:
‘ エラー時は何もしない（元の画像を維持）
If Not fso Is Nothing Then
If fso.FileExists(tempFilePath) Then fso.DeleteFile tempFilePath
End If
OptimizeImage = False
End Function
—
4. コードの解説とアーキテクチャの急所
このコードが他のブログにあるような「動けばいいや」的コードと一線を画す理由は以下の通りだ。
1. `SaveCopyAs` による安全性の担保:
オリジナルファイルを直接破壊するのではなく、`SaveCopyAs` を用いて別名（`_optimized`）で保存している。ネットワークドライブや共有サーバー上で作業する際、万が一のファイル破損やネットワーク切断からデータを守るための鉄則である。
2. 一時ファイルを介した物理ピクセルの削減:
PowerPoint内で単に図形縮小を行うだけでは内部のバイナリが肥大化したままになるが、一度 `Export` でJPEG化し、適切なサイズを指定して `AddPicture` で再配置することで、バイナリそのものの容量を物理的に削り取ることに成功している。
3. ループの逆順処理 (`Step -1`):
コレクション（スライド内のシェイプなど）を削除しながらループを回す場合、正順（1からN）で回すとインデックスがズレて必ずバグる。逆順ループは、要素の増減を伴うコレクション操作の基本中の基本だ。
—
5. 運用上の注意点とさらなる高みへ
- 画質のトレードオフ:
`ppShapeFormatJPEG` でエクスポートする際、極端に縮小しすぎると文字がつぶれたり輪郭がボケたりする。社内規定や提出先の要件（150DPI相当など）に合わせて、必要であれば画像のエクスポート時の寸法調整ロジック（Width/Heightの係数制御）をチューニングしてほしい。
- データベース・クラウド連携への拡張:
このVBAをさらに発展させ、社内のファイルサーバ監視プログラム（PythonやC#製）やRPAからバックグラウンドでキックし、アップロード前に自動でこのマクロを走らせるパイプラインを構築すれば、ストレージ容量の無駄遣いを根本から根絶できる。
業務自動化とは、単に手作業を置き換えることではない。リソースの無駄を削ぎ落とし、システム全体のパフォーマンスを最大化することだ。このコードをあなたの武器庫に加え、肥大化したプレゼン資料の悩みから組織を解放してほしい。
