【実務・中級編】Shape.ForeignTypeを活用した埋め込み画像（BMP/PNG/JPEG）の解像度判定と元サイズへの自動リセット – Visio VBA解析バイブル

Visio VBAを掌握する極限の知見：Shape.ForeignTypeで制圧する埋め込み画像のリセット自動化

開発現場でVisioを扱っていて、最もフラストレーションが溜まる瞬間の一つが「誰かが適当に引き伸ばしてアスペクト比が崩れきった画像シェイプの山」に直面した時ではないか。

マニュアル作成やフロー図の改修において、スクリーンショットやアイコンが不自然に変形している図面は、それだけで成果物のクオリティを著しく低下させる。しかし、これを手動で一つひとつ元の比率に戻していく作業など、エンジニアのやるべき仕事ではない。

今回は、Visioのオブジェクトモデルの深部にある `Shape.ForeignType` を突き詰め、「崩れた画像シェイプをミリ単位で検出し、元のネイティブ解像度のアスペクト比に完全自動でアジャストする」ための、プロダクション品質のVBAソリューションを授けよう。

—

なぜ「画像のリサイズ」で一般のVBAコードは失敗するのか？

初心者がやりがちなアプローチは、シェイプの幅（Width）や高さ（Height）を適当に固定値で割り当てたり、単に `1` を代入して原寸に戻そうとしたりすることだ。しかし、これでは以下の壁にぶ当たる。

1. すべてのシェイプが画像とは限らない：
Visio上では、コネクタ、グループ、CAD図面、OLEオブジェクトなど、多様な異種（Foreign）オブジェクトが混在している。これらを区別せずに処理すると、図面全体が崩壊する。
2. メタファイルの罠：
WMFやEMFなどのベクター系Foreignオブジェクトと、PNG/JPEGなどのラスター系イメージでは、Visio内部でのスケーリング挙動が異なる。
3. ShapeSheetの数式汚染：
単に `Width` プロパティを書き換えるだけでは、ガード（Guard）関数やセル間の数式依存関係（PinX/PinYとの関係）を無視した形になり、シェイプが予期せぬ方向に吹っ飛ぶ。

これらの地雷を踏み抜かないためには、VisioのオブジェクトライフサイクルとForeignTypeの仕様を完全に掌握した設計が不可欠となる。

—

核心：`ForeignType` とシェイプの正体

Visioの `Shape` オブジェクトが外部データや画像である場合、その種別は `Shape.ForeignType` プロパティに格納される。

ラスター画像（`visTypeBitmap`）であると断定できたら、次に重要になるのが「元画像のピクセルアスペクト比」の取得だ。
実は、Visioの埋め込み画像シェイプは、ShapeSheet上の特定のセル（`Width` と `Height`、あるいは内部のForeignデータに関連するセル）から、元画像の縦横比率を逆算することができる。

しかし、最も確実かつエレガントなアプローチは、「一度元の比率を維持した状態で、幅（または高さ）を基準に逆側の寸法を再計算して流し込む」ことだ。

—

プロダクションコード：全自動アスペクト比補正エンジン

以下のコードは、エラーハンドリング、グループシェイプの再帰的走査、そしてShapeSheetの保護（Guard）を考慮した、実務でそのまま使える堅牢なモジュールである。

Option Explicit

‘ =========================================================================
‘ 業務自動化モジュール: 埋め込み画像アスペクト比自動適正化エンジン
‘ 対象: アクティブページの全画像シェイプ（グループ内も再帰的に走査）
‘ =========================================================================
Public Sub NormalizeImageAspectRatios()
Dim vsoPage As Visio.Page
Set vsoPage = ActivePage

If vsoPage Is Nothing Then
MsgBox “アクティブなページが存在しません。”, vbCritical, “エラー”
Exit Sub
End If

‘ 処理カウンター
Dim processedCount As Long
processedCount = 0

‘ 画面描画を停止してパフォーマンスを極限まで高める（超重要テクニック）
Application.ScreenUpdating = False
On Error GoTo ErrorHandler

‘ 再帰的にシェイプ群を走査
Dim vsoShape As Visio.Shape
For Each vsoShape in vsoPage.Shapes
Call ProcessShapeRecursive(vsoShape, processedCount)
Next vsoShape

Application.ScreenUpdating = True
MsgBox “処理が完了しました。” & vbCrLf & “修正された画像シェイプ数: ” & processedCount & ” 件”, vbInformation, “完了”
Exit Sub

ErrorHandler:
Application.ScreenUpdating = True
MsgBox “予期せぬエラーが発生しました: ” & Err.Description, vbCritical, “致命的エラー”
End Sub

‘ ————————————————————————-
‘ 再帰的シェイプ走査プロシージャ（グループ化された画像にも対応）
‘ ————————————————————————-
Private Sub ProcessShapeRecursive(ByVal vsoShape As Visio.Shape, ByRef count As Long)
Dim subShape As Visio.Shape

‘ グループシェイプの場合は中身を再帰処理
If vsoShape.Type = visTypeGroup Then
For Each subShape in vsoShape.Shapes
Call ProcessShapeRecursive(subShape, count)
Next subShape
Exit Sub
End If

‘ シェイプが外部オブジェクト（Foreign）か判定
If vsoShape.ForeignType = visTypeBitmap Then
‘ ラスター画像（BMP, PNG, JPEG）の場合のみ実行
If FixBitmapAspect(vsoShape) Then
count = count + 1
End If
End If
End Sub

‘ ————————————————————————-
‘ 個別画像シェイプのアスペクト比補正コアロジック
‘ ————————————————————————-
Private Function FixBitmapAspect(ByVal vsoShape As Visio.Shape) As Boolean
On Error GoTo SafeExit

Dim origWidth As Double
Dim origHeight As Double
Dim currentWidth As Double
Dim currentHeight As Double

‘ 現在の幅と高さを取得
currentWidth = vsoShape.CellsU(“Width”).ResultIU
currentHeight = vsoShape.CellsU(“Height”).ResultIU

If currentWidth <= 0 Or currentHeight <= 0 Then FixBitmapAspect = False Exit Function End If ' 【極限の知見】 ' Visioの埋め込み画像における「真の元サイズ比率」は、 ' ShapeSheetの ForeignWidth / ForeignHeight セルから取得するのが最も正確。 ' これにより、ユーザーがどれだけ歪ませた変形を行っていても、元のピクセル比率を復元できる。 Dim fWidthCell As Visio.Cell Dim fHeightCell As Visio.Cell On Error Resume Next Set fWidthCell = vsoShape.CellsU("ForeignWidth") Set fHeightCell = vsoShape.CellsU("ForeignHeight") On Error GoTo SafeExit If fWidthCell Is Nothing Or fHeightCell Is Nothing Then ' フォールバック: 万が一Foreign系セルが存在しない場合はスキップ FixBitmapAspect = False Exit Function End If origWidth = fWidthCell.ResultIU origHeight = fHeightCell.ResultIU If origWidth <= 0 Or origHeight <= 0 Then FixBitmapAspect = False Exit Function End If ' 元の比率（アスペクト比 = 幅 / 高さ） Dim targetAspect As Double targetAspect = origWidth / origHeight ' 現在の高さをもとに、適切な幅を再計算する（今回は高さを基準に幅をアジャストする方針） ' ※運用ポリシーに合わせて「幅基準で高さを直す」に変更しても良い Dim newWidth As Double newWidth = currentHeight targetAspect ' Guard関数の有無をチェックし、数式代入時のエラーを防ぐ If vsoShape.CellsU("Width").ContainsFormula Then If InStr(1, UCase(vsoShape.CellsU("Width").FormulaU), "GUARD") > 0 Then
vsoShape.CellsU(“Width”).FormulaU = “” ‘ ガード解除が必要な場合の処置
End If
End If

‘ 寸法を適正値に更新（内部イベントをトリガー）
vsoShape.CellsU(“Width”).ResultIU = newWidth

FixBitmapAspect = True
Exit Function

SafeExit:
FixBitmapAspect = False
End Function

—

現場のエンジニアへ向けたチーフアーキテクトからの提言

1. `ScreenUpdating = False` の絶対死守
Visio VBAにおいて、シェイプの操作ごとに画面描画走査走るコードは「毒」だ。数百個のアイコンが並ぶ図面でこれをやると数分かかる処理が、描画停止を行えば一瞬（1秒未満）で終わる。
2. `CellsU` を使え（UはUniversalのU）
`Cells` ではなく `CellsU` を使うこと。日本語環境やドイツ語環境など、Visioのロケール（言語）依存のバグを防ぐためのプロの鉄則である。
3. データベースや外部ファイル連携への拡張
もしこのツールをさらに発展させ、例えば「社内ニッパチ規格のアイコンマスターDBと突き合わせて、特定の型番の画像データに一括置換したい」という要件がある場合は、`vsoShape.Import` メソッドを組み合わせることで、画像自体の差替えパイプラインへと昇華できる。

手作業での無駄な修正作業は今日で終わりにしよう。このスクリプトを組織の共通テンプレート（`VSTM`）に組み込み、チーム全体の生産性を極限まで引き上げてほしい。