1. 現場の現実：ディスク枯渇によるプレゼンテーション破損事故の解剖
数千枚のスライド、埋め込まれた非圧縮の高解像度TIFFやRAW由来のビットマップ、肥大化したメタデータ――エンタープライズの現場で日々生成される巨大なプレゼンテーションファイルは、ストレージにとって脅威です。
特に問題となるのは、「保存処理の最中にストレージの空き容量が枯渇する」ケースです。PowerPointのネイティブ保存エンジンは、テンポラリファイルへの書き出しとリネームによって原子的（Atomic）な保存を試みます。しかし、残容量が数MBを下回る極限状態では、中途半端なストリーム書き込みによってテンポラリファイルが破損し、元のファイルまで巻き込んで破壊される事故が後を絶ちません。
さらに、標準機能である「画像の圧縮」ダイアログ（`CommandBars.ExecuteMso(“PicturesCompress”)`）はモーダルUIを強制するため、バッチ処理や無人運用のパイプラインを完全に停止させます。
本稿では、Windows APIによる高精度な空き容量事前検知と、UIを一切介さずにスライド内の全画像を走査・再サンプリングしてファイルサイズを削ぎ落とすヘッドレス画像圧縮エンジンを統合した、堅牢なスマートストレージマクロを構築します。
—
2. Windows API `GetDiskFreeSpaceExW` の厳密な実装
ドライブの空き容量をVBAから取得する際、FileSystemObject（FSO）の `Drive.FreeSpace` を使用するのは悪手です。FSOは内部的に2GB/4GBの境界でオーバーフローを起こすレガシー仕様を内包しており、TB級のモダンストレージやネットワーク共有（UNCパス）で破綻します。
採用すべきは、Windowsカーネル直結の `GetDiskFreeSpaceExW` です。
64bit整数（ULARGE_INTEGER）とVBAの型整合性
このAPIは、以下の3つの64bit整数（`ULARGE_INTEGER`）を要求します。
1. 呼び出し元スレッドのユーザーが利用可能な空きバイト数（ディスククォータ考慮）
2. ドライブ全体の総バイト数
3. ドライブ全体の空きバイト数
VBA7（Office 2010以降）の64bit環境（Win64）では `LongLong` 型が利用可能ですが、32bit環境（Win32）では `LongLong` が存在しません。エンタープライズ環境に残存する32bit Officeとの互換性を担保するためには、通貨型（`Currency`）を8バイト整数コンテナとして転用するか、条件付きコンパイル（`#If VBA7`）で分岐させる設計が必須となります。
本実装では、`LongLong` をネイティブに扱えるVBA7/64bit環境を前提としつつ、32bit環境でもオーバーフローを起こさないハイブリッド定義を提示します。
If VBA7 Then
Private Declare PtrSafe Function GetDiskFreeSpaceExW Lib “kernel32” ( _
ByVal lpDirectoryName As LongPtr, _
ByRef lpFreeBytesAvailable As LongLong, _
ByRef lpTotalNumberOfBytes As LongLong, _
ByRef lpTotalNumberOfFreeBytes As LongLong) As Long
Else
Private Declare Function GetDiskFreeSpaceExW Lib “kernel32” ( _
ByVal lpDirectoryName As Long, _
ByRef lpFreeBytesAvailable As Currency, _
ByRef lpTotalNumberOfBytes As Currency, _
ByRef lpTotalNumberOfFreeBytes As Currency) As Long
End If
※32bit環境で `Currency` を受ける場合、値は内部的に10,000倍されて保持されるため、実バイト数を得るには ` 10000` のスケーリング補正を行います。
—
3. ヘッドレス画像圧縮のメカニズム：インプレース・スワップ法
PowerPointオブジェクトモデルには、「画像の画質を一括で下げる」直接的なAPIが存在しません。そこで本アーキテクチャでは、「インプレース・エクスポート/リインポート・スワップ法」を採用します。
処理のアルゴリズム
1. スライド内の全シェイプを再帰走査（グループ化されたシェイプも深掘り）。
2. 画像シェイプ（`msoPicture` または画像を持つ `msoPlaceholder`）を特定。
3. 当該シェイプを一時ディレクトリへ「低解像度JPG（またはPNG）」としてエクスポート。
4. 元の座標（`Left`, `Top`, `Width`, `Height`）、Zオーダー、回転角度を記憶。
5. 同一スライド上に圧縮後画像を `AddPicture` で挿入し、元の位置・ジオメトリを復元。
6. 元の高解像度シェイプを `Delete` し、一時ファイルを破棄。
[高解像度シェイプ] ──(ジオメトリ退避)──> [メモリキャッシュ]
│
├──(低解像度Export)──> [Temp.jpg (縮小)]
│ │
▼ (Delete) ▼ (AddPicture)
[完全破棄] [最適化シェイプ] ──(ジオメトリ復元)
このアプローチにより、Officeの内部画像キャッシュ（埋め込まれた元画像データ）が強制的に破棄され、再サンプリングされた軽量画像へと差し替えられます。
—
4. プロダクションコード：スマートストレージ保存エンジン
以下のモジュールは、指定されたパスの空き容量を評価し、設定された閾値（デフォルト：想定ファイルサイズの3倍、または下限50MB）を下回っている場合に全スライドの画像をダウンサンプリングして保存する完全な実装です。
新規標準モジュール（例: `mod_SmartStorageEngine`）に配置してください。
Option Explicit
‘ ==============================================================================
‘ Module: mod_SmartStorageEngine
‘ Architecture: Defensive Storage-Aware Presentation Persister
‘ ==============================================================================
If VBA7 Then
Private Declare PtrSafe Function GetDiskFreeSpaceExW Lib “kernel32” ( _
ByVal lpDirectoryName As LongPtr, _
ByRef lpFreeBytesAvailable As LongLong, _
ByRef lpTotalNumberOfBytes As LongLong, _
ByRef lpTotalNumberOfFreeBytes As LongLong) As Long
Else
Private Declare Function GetDiskFreeSpaceExW Lib “kernel32″ ( _
ByVal lpDirectoryName As Long, _
ByRef lpFreeBytesAvailable As Currency, _
ByRef lpTotalNumberOfBytes As Currency, _
ByRef lpTotalNumberOfFreeBytes As Currency) As Long
End If
Private Const MINIMUM_SAFE_HEADROOM_BYTES As Double = 52428800# ‘ 50 MB (セーフティマージン)
Private Const TARGET_EXPORT_SCALE_WIDTH As Single = 1024# ‘ 圧縮ターゲット最大横幅(px)
”’
”’
Public Sub SavePresentationSmart(ByVal targetPres As Presentation, ByVal destinationPath As String)
On Error GoTo ErrHandler
Dim targetFolder As String
targetFolder = GetDirectoryPath(destinationPath)
If Len(targetFolder) = 0 Then
Err.Raise vbObjectError + 1001, “SmartStorage”, “無効なディレクトリパスです。”
End If
‘ 1. ドライブの空き容量をリアルタイム検証 (バイト単位)
Dim freeBytesAvailable As Double
freeBytesAvailable = QueryFreeDiskSpace(targetFolder)
‘ 2. プレゼンテーションの想定サイズを概算
‘ ※未保存ファイルはテンポラリサイズが取れないため、初期閾値としてヘッドルームを使用
Dim requiredHeadroom As Double
requiredHeadroom = EstimateRequiredSpace(targetPres)
Debug.Print “Free Space: ” & Format(freeBytesAvailable / 1024 / 1024, “#,
0.00″) & ” MB”
Debug.Print “Required Headroom: ” & Format(requiredHeadroom / 1024 / 1024, “#,
0.00″) & ” MB”
‘ 3. 容量不足の場合、極限画像圧縮パイプラインを起動
If freeBytesAvailable < requiredHeadroom Then
Debug.Print "WARNING: ストレージ残量が閾値を下回っています。画像圧縮処理を開始します..."
CompressAllPicturesInPresentation targetPres
End If
' 4. 原子的保存の実行
targetPres.SaveCopyAs destinationPath
Debug.Print "SUCCESS: プレゼンテーションが安全に出力されました -> ” & destinationPath
Exit Sub
ErrHandler:
Dim errDesc As String: errDesc = Err.Description
Dim errNum As Long: errNum = Err.Number
‘ 必要に応じてロールバックや通知処理を実装
Err.Raise errNum, “SavePresentationSmart”, “保存処理中に致命的エラーが発生しました: ” & errDesc
End Sub
”’
”’
Private Function QueryFreeDiskSpace(ByVal folderPath As String) As Double
‘ パス終端の調整（API要件: ルートまたは既存ディレクトリ）
If Right$(folderPath, 1) <> “\” Then folderPath = folderPath & “\”
Dim result As Long
#If VBA7 Then
Dim userFree As LongLong
Dim totalBytes As LongLong
Dim totalFree As LongLong
result = GetDiskFreeSpaceExW(StrPtr(folderPath), userFree, totalBytes, totalFree)
If result <> 0 Then
‘ LongLongからDoubleへ安全に型変換
QueryFreeDiskSpace = CDbl(userFree)
Else
QueryFreeDiskSpace = 0#
End If
#Else
Dim curUserFree As Currency
Dim curTotalBytes As Currency
Dim curTotalFree As Currency
result = GetDiskFreeSpaceExW(StrPtr(folderPath), curUserFree, curTotalBytes, curTotalFree)
If result <> 0 Then
‘ Currencyの内部スケーリング（10,000）を戻す
QueryFreeDiskSpace = CDbl(curUserFree) 10000#
Else
QueryFreeDiskSpace = 0#
End If
#End If
End Function
”’
”’
Private Function EstimateRequiredSpace(ByVal pres As Presentation) As Double
Dim currentSize As Double
currentSize = 0#
On Error Resume Next
If Len(pres.FullName) > 0 Then
‘ 既存ファイルが存在する場合
currentSize = CDbl(FileLen(pres.FullName))
End If
On Error GoTo 0
Dim estimatedSize As Double
estimatedSize = currentSize 3# ‘ PowerPointの保存テンポラリ生成に必要なバッファ係数
If estimatedSize < MINIMUM_SAFE_HEADROOM_BYTES Then
estimatedSize = MINIMUM_SAFE_HEADROOM_BYTES
End If
EstimateRequiredSpace = estimatedSize
End Function
'''
”’
Private Sub CompressAllPicturesInPresentation(ByVal pres As Presentation)
Dim sld As Slide
Dim shp As Shape
Dim i As Long, j As Long
Dim tempFolder As String
tempFolder = Environ$(“TEMP”) & “\”
‘ 高速化のため画面更新とイベントを抑止
‘ ※PowerPointにはApplication.ScreenUpdatingがないため、ウィンドウの最小化等で代替するか
‘ DoEventsを制御してCOM負荷を下げる
For i = 1 To pres.Slides.Count
Set sld = pres.Slides(i)
‘ 逆順ループ（要素の削除・置換を安全に行うため）
For j = sld.Shapes.Count To 1 Step -1
Set shp = sld.Shapes(j)
ProcessShapeCompression sld, shp, tempFolder
Set shp = Nothing
Next j
Set sld = Nothing
DoEvents ‘ OSのメッセージキューを捌き、UIフリーズを回避
Next i
End Sub
”’
”’
Private Sub ProcessShapeCompression(ByVal sld As Slide, ByVal targetShape As Shape, ByVal tempFolder As String)
‘ グループ化シェイプの再帰処理
If targetShape.Type = msoGroup Then
Dim subShape As Shape
Dim k As Long
For k = targetShape.GroupItems.Count To 1 Step -1
Set subShape = targetShape.GroupItems(k)
ProcessShapeCompression sld, subShape, tempFolder
Set subShape = Nothing
Next k
Exit Sub
End If
‘ 対象がビットマップ画像であるか判定
If targetShape.Type = msoPicture Or (targetShape.Type = msoPlaceholder And targetShape.HasTextFrame = msoFalse) Then
Dim tempFilePath As String
tempFilePath = tempFolder & “ppttemp_” & Format(Timer 1000, “0”) & “_” & Int(Rnd 10000) & “.jpg”
On Error GoTo SkipShape
‘ ジオメトリ・プロパティの退避
Dim sLeft As Single: sLeft = targetShape.Left
Dim sTop As Single: sTop = targetShape.Top
Dim sWidth As Single: sWidth = targetShape.Width
Dim sHeight As Single: sHeight = targetShape.Height
Dim sRotation As Single: sRotation = targetShape.Rotation
Dim zIndex As Long: zIndex = targetShape.ZOrderPosition
‘ 低解像度で一時エクスポート（幅を制限してファイルサイズを削る）
Dim exportWidth As Long, exportHeight As Long
If sWidth > TARGET_EXPORT_SCALE_WIDTH Then
exportWidth = CLng(TARGET_EXPORT_SCALE_WIDTH)
exportHeight = CLng(sHeight (TARGET_EXPORT_SCALE_WIDTH / sWidth))
Else
exportWidth = CLng(sWidth)
exportHeight = CLng(sHeight)
End If
‘ エクスポート実行
targetShape.Export tempFilePath, ppShapeFormatJPG, exportWidth, exportHeight
‘ 元シェイプの削除
targetShape.Delete
‘ 新規シェイプとしてインポート
Dim newShape As Shape
Set newShape = sld.Shapes.AddPicture(tempFilePath, msoFalse, msoTrue, sLeft, sTop, sWidth, sHeight)
‘ プロパティ復元
newShape.Rotation = sRotation
‘ 一時ファイルの破棄
If Len(Dir$(tempFilePath)) > 0 Then
Kill tempFilePath
End If
Set newShape = Nothing
SkipShape:
On Error GoTo 0
End If
End Sub
Private Function GetDirectoryPath(ByVal fullPath As String) As String
Dim pos As Long
pos = InStrRev(fullPath, “\”)
If pos > 0 Then
GetDirectoryPath = Left$(fullPath, pos – 1)
Else
GetDirectoryPath = “”
End If
End Function
—
5. アーキテクトの視点：COMの境界とGDI+の影
なぜ `Shape.Export` なのか？
多くの開発者が `ActivePresentation.SaveAs` の画像形式変換やクリップボード経由の貼り付けを試みて失敗します。クリップボードはOSのグローバル共有リソースであり、バックグラウンド実行中にユーザーの操作や他プロセスの介入によって容易に競合例外（`CLIPBRD_E_CANT_OPEN`）を起こします。
`Shape.Export` はクリップボードを一切経由せず、Office内蔵のグラフィックフィルタを通じて直接ディスクにバイナリを書き出すため、スレッドセーフティの観点から群を抜いて安全です。
メモリリーク（COM参照残存）の徹底排除
大規模プレゼンテーションを処理する際、VBAのガベージコレクションは非常に緩慢です。ループ内で `Set shp = Nothing` や `Set sld = Nothing` を明示的に行わない場合、PowerPointプロセスのプライベートバイト（Private Bytes）は数GBに達し、`Out of Memory`（実行時エラー7）で異常終了します。上記のコードでループ終端ごとに参照を破棄し、`DoEvents` でメッセージポンプを明示的に回しているのは、このメモリクラッシュを物理的に防ぐための必然的な設計です。
さらにその先へ：OpenXMLとGDI+への道標
本アプローチは「PowerPointが起動している環境」で最も安定した結果をもたらします。しかし、さらなる極限を追求する場合、以下の2つのアプローチが存在します。
1. GDI+ API（`gdiplus.dll`）の直接呼出し:
メモリ上で画像ストリームを取得し、JPEGのエンコーダパラメータ（`EncoderQuality`）を明示的に指定して量子化テーブルを制御する。
2. OpenXML（.pptx）のZIP直接操作:
プレゼンテーションを一度通常保存（またはZipArchiveとしてオープン）し、内部の `/ppt/media/` ディレクトリ内のメディアファイルを抽出し、外部ツールや別スレッドで一括不可逆圧縮してZIPを再パッキングする。
これらはCOMオブジェクトモデルのオーバーヘッドを完全にバイパスする手法ですが、コードの保守性とプラットフォーム依存のトレードオフが発生します。本稿で提示したWin32 API＋インプレース置換マクロは、「VBA単体で完結し、現場で即座に稼働させられる最高峰の防衛線」です。
ディスク容量という物理リソースをコードから見極め、限界状況でもファイルを死守する――その執念こそが、エンタープライズアーキテクチャの真髄です。
