【CorelDRAW VBA】配置された全ビットマップ解像度一括スキャン＆ログ化ツール：印刷事故を防ぐ堅牢な実務マクロの設計
デザイン制作の現場において、「低解像度画像のまま入稿してしまい、印刷後にボケた仕上がりになってしまった」というヒューマンエラーは、最も避けなければならない致命的な事故の一つです。
特に、複数のデザイナーがレイアウトを持ち寄った複雑なドキュメントや、外部から支給された素材が混在する案件では、目視によるチェックには限界があります。
今回は、CorelDRAWドキュメント内に点在するすべてのビットマップ画像をプログラムが自動で巡回し、指定した基準値（例：300 dpi）未満のものを瞬時にスキャン、さらに検証結果を外部ログとして出力するプロダクションレベルのVBAツールを解説します。
単なる「動くコード」の提示にとどまらず、CorelDRAWのオブジェクトモデルの特性を踏まえた「バグの起きない堅牢な設計思想」をあなたに伝授します。
—
1. 開発現場で陥りがちな罠と、正しいアプローチ
CorelDRAW VBAでビットマップを操作する際、多くの初学者が陥る罠があります。それは、「ページ上のシェイプをただ上から順に舐めていけばいい」という安易な設計です。
実際のドキュメント構造は、そう単純ではありません。
- グループ化（Group） の内部に画像が隠れている。
- レイヤー（Layer） が複数存在し、非表示レイヤーにもデータが眠っている。
- パワーКリップ（PowerClip） のコンテナ内部に画像が格納されている。
これらを平坦なループで処理しようとすると、グループ内の画像を見落としたり、予期せぬオブジェクト型エラー（`Run-time error ‘438’: Object doesn’t support this property or method`）でマクロがクラッシュします。
堅牢な設計の要件
1. 再帰的（Recursive）な走査ロジック: グループやPowerClipのネスト構造の深さに関わらず、全ての葉（Leaf）ノードまで確実に到達する。
2. 厳密な型安全（Type Guarding）: `Shape.Type` プロパティを事前に判定し、ビットマップ（`cdrBitmapShape`）であるものだけを安全にキャストして処理する。
3. 効率的なI/O処理: 大量のログを都度ファイルに書き込むのではなく、メモリ上で構築してから一括出力する。
—
2. プロダクションコード：解像度スキャナー＆ログ出力マクロ
以下のコードは、実務の現場でそのままコピー＆ペーストして利用できる完全版のVBAモジュールです。イミディエイトウィンドウへの出力だけでなく、デスクトップへのテキストログ出力までを堅牢にこなします。
Option Explicit
‘ ==============================================================================
‘ 処理名: ドキュメント内ビットマップ解像度一括スキャンツール
‘ 概要 : ページ内の全ビットマップ（ネスト構造・PowerClip内を含む）を走査し、
基準解像度未満のものを検知してログファイルに出力する。
‘ ==============================================================================
Sub ScanBitmapResolution()
‘ — 定数定義 —
Const TARGET_DPI As Double = 300# ‘ 許容する最低解像度（dpi）
‘ — 変数宣言 —
Dim doc As Document
Dim totalChecked As Long
Dim lowResCount As Long
Dim logData As String
Dim logFilePath As String
‘ アクティブドキュメントの存在確認
If ActiveDocument Is Nothing Then
MsgBox “処理対象のドキュメントが開かれていません。”, vbCritical, “エラー”
Exit Sub
End If
Set doc = ActiveDocument
totalChecked = 0
lowResCount = 0
logData = “”
‘ ログヘッダーの作成
logData = “====================================================” & vbCrLf
logData = logData & ” ビットマップ解像度スキャンレポート” & vbCrLf
logData = logData & ” 対象ファイル: ” & doc.Name & vbCrLf
logData = logData & ” 基準解像度 : ” & TARGET_DPI & ” dpi 以上” & vbCrLf
logData = logData & ” 実行日時 : ” & Now & vbCrLf
logData = logData & “====================================================” & vbCrLf & vbCrLf
‘ 処理の高速化と画面描画の凍結
doc.BeginCommandGroup “Bitmap Resolution Check”
Optimization = True
EventsEnabled = False
On Error GoTo ErrorHandler
‘ ページ全体のシェイプ群を再帰的にスキャン
Dim sh As Shape
For Each sh In doc.Pages.ActivePage.Shapes
Call ProcessShape(sh, TARGET_DPI, totalChecked, lowResCount, logData)
Next sh
‘ スキャン結果のまとめをログに追加
logData = logData & “—————————————————-” & vbCrLf
logData = logData & ” スキャン完了: 総チェック数 = ” & totalChecked & ” 件” & vbCrLf
logData = logData & ” 警告対象（低解像度） = ” & lowResCount & ” 件” & vbCrLf
logData = logData & “—————————————————-” & vbCrLf
‘ ログファイルをデスクトップに出力
logFilePath = CreateTextLog(logData, doc.Name)
‘ 終了処理
Optimization = False
EventsEnabled = True
doc.EndCommandGroup
‘ 結果通知
If lowResCount > 0 Then
MsgBox “スキャン完了: ” & lowResCount & ” 件の低解像度画像が検出されました。” & vbCrLf & _
“詳細は以下のログを確認してください:” & vbCrLf & logFilePath, vbExclamation, “警告: 印刷事故リスクあり”
Else
MsgBox “スキャン完了: 検出された画像はすべて基準値（” & TARGET_DPI & ” dpi）を満たしています。”, vbInformation, “チェック合格”
End If
Exit Sub
ErrorHandler:
‘ エラー時のクリーンアップ
Optimization = False
EventsEnabled = True
doc.EndCommandGroup
MsgBox “予期せぬエラーが発生しました: ” & Err.Description, vbCritical, “システムエラー”
End Sub
‘ ==============================================================================
‘ サブルーチン: シェイプを再帰的に解析する（グループ・PowerClip対応）
‘ ==============================================================================
Private Sub ProcessShape(ByRef sh As Shape, ByVal targetDpi As Double, ByRef totalCount As Long, ByRef lowCount As Long, ByRef log As String)
On Error GoTo SafeExit
‘ シェイプの種類に応じた分岐
Select Case sh.Type
Case cdrBitmapShape
‘ 通常のビットマップ
totalCount = totalCount + 1
Call EvaluateBitmap(sh, targetDpi, totalCount, lowCount, log)
Case cdrGroupShape
‘ グループ化されている場合は内部を再帰走査
Dim subSh As Shape
For Each subSh In sh.Shapes
Call ProcessShape(subSh, targetDpi, totalCount, lowCount, log)
Next subSh
Case Else
‘ PowerClipなどのコンテナオブジェクト内にシェイプが存在する場合の考慮
If sh.HasShapes Then
Dim innerSh As Shape
For Each innerSh In sh.Shapes
Call ProcessShape(innerSh, targetDpi, totalCount, lowCount, log)
Next innerSh
End If
End Select
SafeExit:
Exit Sub
End Sub
‘ ==============================================================================
‘ サブルーチン: 個別ビットマップの解像度評価とログ蓄積
‘ ==============================================================================
Private Sub EvaluateBitmap(ByRef sh As Shape, ByVal targetDpi As Double, ByVal index As Long, ByRef lowCount As Long, ByRef log As String)
Dim bmp As Bitmap
Dim resX As Double, resY As Double
Dim statusMsg As String
Set bmp = sh.Bitmap
‘ 解像度（dpi）の取得
resX = bmp.ResolutionX
resY = bmp.ResolutionY
‘ 判定（X軸またはY軸のいずれかが基準未満の場合）
If (resX < targetDpi) Or (resY < targetDpi) Then
lowCount = lowCount + 1
statusMsg = "[要警告: 低解像度]"
Else
statusMsg = "[OK]"
End If
' ログ行の構築
log = log & statusMsg & " ﾌﾞジェクトID: " & sh.StaticID & vbCrLf
log = log & " - サイズ (mm): " & Format(sh.SizeWidth, "0.0") & " x " & Format(sh.SizeHeight, "0.0") & vbCrLf
log = log & " - 解像度 (dpi): Horizontal=" & Format(resX, "0.0") & ", Vertical=" & Format(resY, "0.0") & vbCrLf
log = log & " - カラーモード: " & GetColorModeName(bmp.ColorMode) & vbCrLf
log = log & "----------------------------------------------------" & vbCrLf
End Sub
' ==============================================================================
' 関数: カラーモード定数を人間が読める文字列に変換
' ==============================================================================
Private Function GetColorModeName(ByVal mode As Long) As String
Select Case mode
Case cdrCMYK: GetColorModeName = "CMYK"
Case cdrRGB: GetColorModeName = "RGB"
Case cdrGrayscale: GetColorModeName = "グレースケール"
Case cdrMonochrome: GetColorModeName = "モノクロ2値"
Case Else: GetColorModeName = "その他 (" & mode & ")"
End Function
End Function
' ==============================================================================
' 関数: テキストログをWindowsのデスクトップに書き出す
' ==============================================================================
Private Function CreateTextLog(ByVal logContent As String, ByVal docName As String) As String
Dim fso As Object
Dim ts As Object
Dim desktopPath As String
Dim filePath As String
Set fso = CreateObject("Scripting.FileSystemObject")
' デスクトップパスの取得
desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
' ファイル名の生成（タイムスタンプ付与）
Dim timeStamp As String
timeStamp = Format(Now, "yyyymmdd_hhnnss")
filePath = desktopPath & "\Preflight_Log_" & Replace(docName, ".cdr", "") & "_" & timeStamp & ".txt"
' テキストファイルとして書き出し
Set ts = fso.CreateTextFile(filePath, True)
ts.Write logContent
ts.Close
CreateTextLog = filePath
End Function
---
3. コードの技術的解説とエンジニアリングのポイント
① 画面描画の凍結による爆速化 (`Optimization = True`)
CorelDRAW VBAにおいて、マクロ実行中にオブジェクトが再描画されると、処理速度が著しく低下します。コード内にある以下の記述は、大規模なドキュメントを処理する上で必須の定石です。
Optimization = True
EventsEnabled = False
‘ … 処理本体 …
Optimization = False
EventsEnabled = True
これにより、CPUリソースが描画ではなく純粋なデータ処理に集中し、処理速度が最大で数十倍に跳ね上がります。
② 再帰呼び出しによる「隠れオブジェクト」の網羅
`ProcessShape` プロシージャでは、通常のシェイプだけでなく、グループ(`cdrGroupShape`)やコンテナ構造（PowerClip等）を検知した瞬間に、自身の関数を再度呼び出す「再帰処理」を採用しています。これにより、何重にも入れ子になった複雑なデザインデータであっても、見落としゼロでビットマップを捕捉できます。
③ 安全なエラーハンドリングとリソース解放
VBAにおいて、途中でエラーが発生したまま `Optimization = True` が解除されないと、CorelDRAWの画面が固まったまま操作不能になるという最悪の事態を招きます。これを防ぐため、`On Error GoTo ErrorHandler` を設置し、異常終了時であっても確実に描画フラグを元に戻す堅牢なアーキテクチャにしています。
—
4. 実務への導入とさらなる拡張性
このマクロを導入することで、これまでベテランスタッフが目視で行っていたプリフライト（印刷前検証）作業を完全に自動化できます。
さらに実務を高度化させるためのアイデアとして、以下の拡張も容易に行えます。
- 自動置換・警告レイヤーへの移動: 基準値未満の画像を特定した際、自動的にハイライト用のアウトライン枠を付与する。
- データベース連携: 出力するログをテキストファイルではなく、社内の生産管理システム（Web API）へ `POST` 送信し、案件ごとの品質データを一元管理する。
業務自動化の本質は、「人の記憶や目視に頼らない仕組みの構築」にあります。ぜひこのツールをあなたの開発環境に組み込み、印刷事故ゼロの堅牢なワークフローを実現してください。
