プレゼンテーションの静寂を支配せよ：フォント・アーキテクチャの統一と自動化の真髄
ビジネスの現場において、フォントの乱れは「思考の乱れ」と同義だ。
複数の人間が介在したPowerPointファイルは、異なる環境、異なる時代のフォントが入り混じった、いわば「技術的負債の墓場」と化す。これを手作業で修正するなど、エンジニアの仕事ではない。
我々が求めるのは、スライドの階層構造を深層まで走査し、すべてのテキストボックス、図形、グループ化されたオブジェクト、そしてスライドマスターの隅々に至るまで、一分の隙もなく「社内標準フォント」へと強制執行する、冷徹なまでの自動化機構である。
本稿では、単なるループ処理を超えた、プロフェッショナルな「フォントマネージャーマクロ」の実装について解説する。
—
1. オブジェクト・トラバーサルの設計思想
PowerPointのオブジェクトモデルは、Excelほど素直ではない。
スライド上の `Shape` は、単体であることもあれば、複雑にネストされた `GroupShape` であることもある。また、テーブル（Table）内のセルや、スライドマスター、ノートなど、テキストが潜む場所は多岐にわたる。
中級以上のエンジニアが意識すべきは、「再帰的構造の走査」と「プロパティの完全性」だ。
特に日本語環境においては、`Font.Name`（英数用）と `Font.NameFarEast`（和文用）の双方を制御しなければならない。この区別を怠るコードは、現場では使い物にならない。
2. Windows APIによるパフォーマンスの極限制御
PowerPoint VBAには、Excelのような `Application.ScreenUpdating = False` が存在しない（厳密には存在するが、期待通りに動作しない局面が多い）。大規模なスライド（100枚超）を処理する場合、再描画のオーバーヘッドは無視できない。
ここで我々は、Windows API（`SendMessage`）を叩き、ウィンドウの描画をOSレベルでロックする手法を採る。
If VBA7 Then
Private Declare PtrSafe Function SendMessage Lib “user32” Alias “SendMessageA” (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function FindWindow Lib “user32” Alias “FindWindowA” (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Else
Private Declare Function SendMessage Lib “user32” Alias “SendMessageA” (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function FindWindow Lib “user32” Alias “FindWindowA” (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
End If
Private Const WM_SETREDRAW As Long = &HB
3. 実装：プロフェッショナル・フォントマネージャー
以下に示すコードは、スライドマスター、レイアウト、個別スライドのすべてを走査し、指定したフォントへと一括置換を行う。エラーハンドリングとオブジェクトの解放にも細心の注意を払っている。
Option Explicit
‘ —————————————————————————–
‘ 企業標準フォント定義
‘ —————————————————————————–
Private Const STD_FONT_NAME_FE As String = “BIZ UDPゴシック” ‘ 和文フォント
Private Const STD_FONT_NAME_EN As String = “Segoe UI” ‘ 欧文フォント
Sub ExecuteUniversalFontHarmonizer()
Dim targetPres As Presentation
Set targetPres = ActivePresentation
Dim hwnd As LongPtr
hwnd = FindWindow(“PPTFrameClass”, Application.Caption)
On Error GoTo ErrorHandler
‘ パフォーマンス最適化：描画停止
If hwnd <> 0 Then SendMessage hwnd, WM_SETREDRAW, 0, ByVal 0&
Debug.Print “— Font Scan & Replace Operation Started —”
‘ 1. スライドマスターの処理
Dim master As Design
For Each master In targetPres.Designs
ProcessShapes master.SlideMaster.Shapes
Next master
‘ 2. 各スライドの処理
Dim sld As Slide
For Each sld In targetPres.Slides
ProcessShapes sld.Shapes
‘ ノート部分も対象とする場合
If sld.HasNotesPage Then
ProcessShapes sld.NotesPage.Shapes
End If
Next sld
‘ 3. 別名保存（タイムスタンプ付与）
Dim exportPath As String
exportPath = CreateExportPath(targetPres.FullName)
targetPres.SaveAs exportPath
MsgBox “フォント置換及び保存が完了しました。” & vbCrLf & “保存先: ” & exportPath, vbInformation
CleanUp:
‘ 描画再開
If hwnd <> 0 Then SendMessage hwnd, WM_SETREDRAW, 1, ByVal 0&
Exit Sub
ErrorHandler:
Debug.Print “Critical Error: ” & Err.Description
Resume CleanUp
End Sub
‘ —————————————————————————–
‘ 図形集合を走査する（再帰構造対応）
‘ —————————————————————————–
Private Sub ProcessShapes(ByRef shps As Shapes)
Dim shp As Shape
For Each shp In shps
‘ グループ化されている場合は再帰呼び出し
If shp.Type = msoGroup Then
ProcessShapes shp.GroupItems
Else
ApplyFontToShape shp
End If
‘ テーブル構造への対応
If shp.HasTable Then
Dim r As Long, c As Long
For r = 1 To shp.Table.Rows.Count
For c = 1 To shp.Table.Columns.Count
ApplyFontToTextRange shp.Table.Cell(r, c).Shape.TextFrame.TextRange
Next c
Next r
End If
Next shp
End Sub
‘ —————————————————————————–
‘ 個別図形へのフォント適用
‘ —————————————————————————–
Private Sub ApplyFontToShape(ByRef shp As Shape)
On Error Resume Next ‘ テキストを持たない図形をスキップ
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
ApplyFontToTextRange shp.TextFrame.TextRange
End If
End If
On Error GoTo 0
End Sub
‘ —————————————————————————–
‘ TextRangeレベルでのフォント置換
‘ —————————————————————————–
Private Sub ApplyFontToTextRange(ByRef tr As TextRange)
With tr.Font
.Name = STD_FONT_NAME_EN
.NameFarEast = STD_FONT_NAME_FE
End With
End Sub
‘ —————————————————————————–
‘ 保存パスの生成
‘ —————————————————————————–
Private Function CreateExportPath(ByVal originalPath As String) As String
Dim fso As Object
Set fso = CreateObject(“Scripting.FileSystemObject”)
Dim dirPath As String: dirPath = fso.GetParentFolderName(originalPath)
Dim baseName As String: baseName = fso.GetBaseName(originalPath)
Dim extension As String: extension = fso.GetExtensionName(originalPath)
Dim timestamp As String: timestamp = Format(Now, “yyyymmdd_HHMMSS”)
CreateExportPath = dirPath & “\” & baseName & “_Fixed_” & timestamp & “.” & extension
Set fso = Nothing
End Function
—
4. アーキテクトの視点：なぜこのコードなのか
4.1. `NameFarEast` の重要性
VBAで単に `.Name = “MS UI Gothic”` と指定しても、日本語環境では意図通りにならないことが多い。VBAの内部では、欧文フォント（Name）と東アジア言語フォント（NameFarEast）を明確に区別して保持しているからだ。この両方を明示的に上書きすることが、文字化けや意図しないフォント混在を防ぐ唯一の道である。
4.2. 再帰呼び出しによるグループ化解除の回避
初心者はよく `shp.Ungroup` を行おうとするが、これは禁じ手だ。アニメーション設定やZ順（重なり順）が破壊されるリスクがある。本コードのように、グループ内の `GroupItems` を再帰的に走査することで、スライドの構造を維持したまま中身だけを書き換えるのが正解だ。
4.3. メモリ管理とCOMオブジェクト
`FileSystemObject` などの外部ライブラリを扱う際、本コードでは `Set fso = Nothing` による明示的な解放を行っている。VBAのガベージコレクションは時として気まぐれであり、特に大量のファイルを一括処理（バッチ処理）する際には、こうした「後始末」の有無がシステムの安定性を左右する。
5. さらなる高みへ：システム間連携の展望
このマクロをさらに進化させるならば、以下の拡張が考えられる。
1. JSON設定ファイルとの連携: フォント名をコード内にハードコードせず、外部のJSONやConfigファイルから読み込む。
2. PDF一括変換エンジン: 保存時に `ExportAsFixedFormat` メソッドを呼び出し、フォント統一済みのPDFを自動生成する。
3. 不適合フォントの検知ログ: どのスライドのどの図形に「社外フォント」が残っていたかをCSVに出力し、監査ログとする。
結論
PowerPoint VBAを掌握することは、単なる事務作業の効率化ではない。それは、組織内の情報の「顔つき」を整え、ブランドアイデンティティを守るエンジニアリングだ。
このコードをベースに、貴殿の環境に合わせた「極限の最適化」を施してほしい。レガシーな技術であっても、その深淵に触れることで、真のアーキテクトとしての道が開けるはずだ。
