Visio VBAの深淵：Shape.Parentを極める多角的階層追跡アーキテクチャ
Visioは、Microsoft Officeファミリーの中でも極めて異質なオブジェクトモデルを持っています。一見、ExcelのセルやWordの段落のような単純な階層構造に見えますが、その実態は「グラフィカルな2D接続関係」と「論理的な包含関係（グループ・コンテナ・リスト）」、そして「ドキュメント・ページという物理階層」が複雑に絡み合った多次元グラフデータベースです。
多くの開発者が、単なる親要素のループとして `Do While Not Shape.Parent Is Nothing` のようなコードを書き、コンテナやネストされたグループ、あるいはマスタシェイプの壁に突き当たって沈没していきます。
本稿では、Visio VBAにおける階層構造の「真の仕様」を解き明かし、COM参照リークを完全に防ぎながら、任意のShapeから「グループ」「コンテナ」「ページ」「ドキュメント」の所属元をミリ秒単位で正確に特定する、堅牢な共通クラスの実装方法を解説します。
—
1. Visioオブジェクトモデルの「罠」と「本質」
階層追跡の実装に入る前に、我々が対峙しているVisioオブジェクトモデルの特殊性と、直面せざるを得ない3つの罠について整理します。
罠①：`Shape.Parent` の動的型（Dynamic Typing）
VBAの `Shape.Parent` プロパティは、コンパイル時には `Object` 型（あるいは `Anonymity`）を返します。実行時、このプロパティが返すオブジェクトは状況によって動的に変化します。
- 最上位のShapeの場合：`Visio.Page` または `Visio.Master`
- グループ化された内部のShapeの場合：親となる `Visio.Shape`
- マスタシェイプ（ステンシル内）のShapeの場合：`Visio.Master`
これらを `TypeName` 関数による文字列比較で判定するのは極めて危険です。多言語環境（ローカライズ版）やOfficeのアップデートによって、内部的なクラス名表記が揺らぐ可能性があるためです。判定には必ず `TypeOf … Is …` 演算子を使用しなければなりません。
罠②：物理的親子（Group）と論理的親子（Container）の乖離
Visio 2010で導入された「コンテナ（Container）」および「リスト（List）」は、視覚的にはShapeを内部に含んでいますが、物理的な `Shape.Parent` はコンテナShapeではありません。
コンテナ内のShapeの `Parent` は、コンテナが置かれている `Page`（または上位グループ）です。コンテナ関係を追跡するには、`Shape.MemberOfContainers` という全く別のルートを通る必要があります。これを混同すると、論理的な包含関係を見失うことになります。
罠③：COM参照カウントとメモリリーク
VBAはCOM（Component Object Model）の参照カウントによってオブジェクトの寿命を管理しています。再帰的に `Parent` を参照していく過程で、一時的なCOMラッパーオブジェクトが大量に生成されます。これらを明示的に `Nothing` で解放（リリース）しない場合、特に別プロセス（Excel等）からVisioをオートメーション操作している環境において、「Visioのプロセス（visio.exe）がタスクマネージャーに残り続ける」という致命的な不具合を誘発します。
—
2. 極限の階層追跡クラス：`VisioHierarchyTracker`
これらの課題をすべて解決するために、再帰処理、型安全、論理/物理関係の分離、そして徹底したメモリ管理（ガベージコレクションへの配慮）を組み込んだ共通クラスを設計しました。
クラスモジュール：`VisioHierarchyTracker.cls`
以下のコードを、VBAプロジェクトのクラスモジュール（名前：`VisioHierarchyTracker`）にインポートして使用してください。
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 ‘True
END
Attribute VB_Name = “VisioHierarchyTracker”
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
‘ ==============================================================================
‘ クラス名: VisioHierarchyTracker
‘ 目的: Visio.Shape の物理的・論理的階層を安全かつ高速に遡り、
‘ 所属するグループ、コンテナ、ページ、ドキュメントを特定する。
‘ ==============================================================================
‘ API宣言：別プロセス操作時や大規模処理時の高精度メモリクリーンアップ用
If VBA7 Then
Private DeclarePtrSafe Sub CoFreeUnusedLibraries Lib “ole32.dll” ()
Else
Private Declare Sub CoFreeUnusedLibraries Lib “ole32.dll” ()
End If
”’
”’
Public Function GetPage(ByVal targetShape As Visio.Shape) As Visio.Page
Set GetPage = Nothing
If targetShape Is Nothing Then Exit Function
Dim currentParent As Object
On Error GoTo ErrorHandler
Set currentParent = targetShape.Parent
Do While Not currentParent Is Nothing
If TypeOf currentParent Is Visio.Page Then
Set GetPage = currentParent
Exit Do
ElseIf TypeOf currentParent Is Visio.Shape Then
‘ 親がグループShapeの場合はさらに上層へ
Set currentParent = currentParent.Parent
ElseIf TypeOf currentParent Is Visio.Master Then
‘ マスタシェイプ編集画面などの場合
Exit Do
Else
Exit Do
End If
Loop
CleanUp:
Set currentParent = Nothing
Exit Function
ErrorHandler:
‘ エラーログ処理（必要に応じて実装）
Resume CleanUp
End Function
”’
”’
Public Function GetDocument(ByVal targetShape As Visio.Shape) As Visio.Document
Set GetDocument = Nothing
Dim targetPage As Visio.Page
Set targetPage = GetPage(targetShape)
If Not targetPage Is Nothing Then
On Error Resume Next
Set GetDocument = targetPage.Document
On Error GoTo 0
Else
‘ マスタシェイプ内に存在する場合のフォールバック
Dim currentParent As Object
Set currentParent = targetShape.Parent
Do While Not currentParent Is Nothing
If TypeOf currentParent Is Visio.Master Then
Set GetDocument = currentParent.Document
Exit Do
End If
Set currentParent = currentParent.Parent
Loop
Set currentParent = Nothing
End If
Set targetPage = Nothing
End Function
”’
”’ グループに属していない場合はNothingを返します。
”’
Public Function GetRootGroup(ByVal targetShape As Visio.Shape) As Visio.Shape
Set GetRootGroup = Nothing
If targetShape Is Nothing Then Exit Function
Dim currentParent As Object
Dim candidateGroup As Visio.Shape
On Error GoTo ErrorHandler
Set currentParent = targetShape.Parent
Set candidateGroup = Nothing
Do While Not currentParent Is Nothing
If TypeOf currentParent Is Visio.Shape Then
‘ 親がShape（＝グループ化Shape）である場合、それを候補として保持
Set candidateGroup = currentParent
Set currentParent = currentParent.Parent
Else
‘ PageやMasterに到達した時点でループ終了
Exit Do
End If
Loop
If Not candidateGroup Is Nothing Then
Set GetRootGroup = candidateGroup
End If
CleanUp:
Set currentParent = Nothing
Set candidateGroup = Nothing
Exit Function
ErrorHandler:
Resume CleanUp
End Function
”’
”’
”’ 対象Shape
”’
Public Function GetContainers(ByVal targetShape As Visio.Shape) As Collection
Dim resultCollection As New Collection
Set GetContainers = resultCollection
If targetShape Is Nothing Then Exit Function
On Error GoTo ErrorHandler
Dim containerIDs() As Long
Dim i As Integer
Dim doc As Visio.Document
Dim pag As Visio.Page
Set pag = GetPage(targetShape)
If pag Is Nothing Then Exit Function
‘ Shape.MemberOfContainers はコンテナのID配列を返す（Visio 2010以降）
containerIDs = targetShape.MemberOfContainers
For i = LBound(containerIDs) To UBound(containerIDs)
Dim containerShape As Visio.Shape
Set containerShape = pag.Shapes.ItemFromID(containerIDs(i))
If Not containerShape Is Nothing Then
resultCollection.Add containerShape
End If
Set containerShape = Nothing
Next i
CleanUp:
Set pag = Nothing
Exit Function
ErrorHandler:
‘ コンテナが存在しない場合や配列が初期化されていない場合は空のコレクションを返す
Resume CleanUp
End Function
”’
”’
Public Sub ForceGarbageCollection()
On Error Resume Next
‘ Windows APIを呼び出し、参照カウントが0になったDLL（COM）を即時解放
CoFreeUnusedLibraries
On Error GoTo 0
End Sub
—
3. 実践：ユースケースに合わせた呼び出しコード
作成した `VisioHierarchyTracker` クラスを用いて、アクティブなページ上の全図形を走査し、各図形が「どのグループの内部にあり、どのコンテナに囲まれているか」を瞬時に解析してイミディエイトウィンドウに出力するデモコードです。
標準モジュール：`Mod_Demo_Hierarchy`
Option Explicit
Public Sub AnalyzeSelectedShapes()
‘ パフォーマンス向上のため描画更新とイベントを停止
Dim previousScreenUpdating As Boolean
Dim previousEventsEnabled As Boolean
previousScreenUpdating = ActiveWindow.Application.ScreenUpdating
previousEventsEnabled = ActiveWindow.Application.EventsEnabled
ActiveWindow.Application.ScreenUpdating = False
ActiveWindow.Application.EventsEnabled = False
‘ トラッカークラスのインスタンス化
Dim tracker As New VisioHierarchyTracker
Dim targetShape As Visio.Shape
‘ 選択されているShapeを対象にする
If ActiveWindow.Selection.Count = 0 Then
MsgBox “解析対象のシェイプを選択してください。”, vbExclamation, “警告”
GoTo CleanUp
End If
Debug.Print “=== 階層構造解析レポート ===”
Dim i As Integer
For i = 1 To ActiveWindow.Selection.Count
Set targetShape = ActiveWindow.Selection(i)
Debug.Print “—————————————-”
Debug.Print “対象Shape名: ” & targetShape.Name & ” (ID: ” & targetShape.ID & “)”
‘ 1. 所属ドキュメントの特定
Dim doc As Visio.Document
Set doc = tracker.GetDocument(targetShape)
If Not doc Is Nothing Then
Debug.Print ” [Document] -> ” & doc.Name
End If
‘ 2. 所属ページの特定
Dim pag As Visio.Page
Set pag = tracker.GetPage(targetShape)
If Not pag Is Nothing Then
Debug.Print ” [Page] -> ” & pag.Name
End If
‘ 3. 最上位グループの特定
Dim rootGroup As Visio.Shape
Set rootGroup = tracker.GetRootGroup(targetShape)
If Not rootGroup Is Nothing Then
Debug.Print ” [RootGroup]-> ” & rootGroup.Name & ” (ID: ” & rootGroup.ID & “)”
Else
Debug.Print ” [RootGroup]-> なし（最上位物理レイヤー）”
End If
‘ 4. 所属コンテナ（論理階層）の特定
Dim containers As Collection
Set containers = tracker.GetContainers(targetShape)
If containers.Count > 0 Then
Dim containerObj As Variant
For Each containerObj In containers
Dim cShape As Visio.Shape
Set cShape = containerObj
Debug.Print ” [Container]-> ” & cShape.Name & ” (ID: ” & cShape.ID & “)”
Set cShape = Nothing
Next
Else
Debug.Print ” [Container]-> なし”
End If
‘ 明示的解放
Set doc = Nothing
Set pag = Nothing
Set rootGroup = Nothing
Set containers = Nothing
Set targetShape = Nothing
Next i
Debug.Print “========================================”
CleanUp:
‘ クラスインスタンスの破棄とCOM解放
Set tracker = Nothing
‘ 描画設定の復旧
ActiveWindow.Application.ScreenUpdating = previousScreenUpdating
ActiveWindow.Application.EventsEnabled = previousEventsEnabled
‘ メモリの強制整理
Call CoFreeUnusedLibraries_Manual
MsgBox “解析が完了しました。イミディエイトウィンドウを確認してください。”, vbInformation, “完了”
End Sub
Private Sub CoFreeUnusedLibraries_Manual()
On Error Resume Next
‘ COMの不要ライブラリ解放を安全に呼び出す（標準モジュール用フォールバック）
Dim tracker As New VisioHierarchyTracker
tracker.ForceGarbageCollection
Set tracker = Nothing
On Error GoTo 0
End Sub
—
4. プロフェッショナルが知るべき実装の「深層」
この実装には、ただコードを写すだけでは得られない、実務上の「血の通った最適化」が施されています。その急所を解説します。
① `TypeOf` によるインターフェースクエリの優位性
VBAでよく使われる `TypeName(obj)` は、オブジェクトモデルの「名前」を内部で解決して文字列を返すため、以下のような問題を引き起こします。
- 処理速度のオーバーヘッド：実行時に文字列の比較を行うため、数千個のShapeをループ処理すると無視できないパフォーマンス低下を招く。
- 多言語版でのバグ：一部のOfficeオブジェクトでは、言語環境によって異なる文字列が返ってくるバグが歴史的に存在した。
これに対し、`TypeOf obj Is Visio.Page` は、COMの基本機能である `QueryInterface` を内部で呼ぶため、マシン語レベルのポインタ比較となり、圧倒的な高速性と安全性が保証されます。
② `Application.ScreenUpdating` と `DeferRecalc` の二重奏
VisioのVBAで大量のオブジェクトを走査、あるいは操作する際、最速化の鍵は `ScreenUpdating` だけではありません。
今回はデータ取得のみなので省いていますが、もしこの階層追跡を基にシェイプのプロパティを書き換える（ShapeSheetを変更する）場合、必ず以下の設定を併用してください。
Application.ScreenUpdating = False
Application.DeferRecalc = True ‘ 数式の再計算を一時保留
‘ — 処理 —
Application.DeferRecalc = False
Application.ScreenUpdating = True
`DeferRecalc`（再計算保留）を忘れると、親オブジェクトを遡るたびに、Visioがシェイプシート（ShapeSheet）の接続情報を再計算してしまい、処理時間が指数関数的に増大します。
③ なぜ `CoFreeUnusedLibraries` を呼ぶのか？
Private DeclarePtrSafe Sub CoFreeUnusedLibraries Lib “ole32.dll” ()
これは、特に「ExcelやAccessからVisioをリモート制御（オートメーション）する」システムにおいて威力を発揮します。
VBAのランタイムは、オブジェクト変数に `Nothing` が代入されても、即座にそのCOMサーバー（Visioの実体）のDLLやメモリを解放せず、キャッシュとして保持する挙動を示します。このため、バックグラウンドに「ゴーストプロセス」として `visio.exe` が残る問題が多発します。
`CoFreeUnusedLibraries` を明示的に呼び出すことで、参照カウントがゼロになったCOMコンポーネントを強制的に解放し、OSに対してクリーンな状態を担保させることができます。
—
5. まとめ：レガシーとモダンを繋ぐ「極限の抽象化」
Visioのオブジェクトモデルは、1990年代に設計された非常に強固なCOMアーキテクチャの上に成り立っています。この伝統的な設計思想を正しく理解せず、安易なループ処理で階層を操作しようとすると、参照リーク、プロセスハング、あるいはバージョン互換性の問題に直面します。
本稿で提示した `VisioHierarchyTracker` クラスは、以下を徹底することでその問題を克服しています。
1. 物理（Group）と論理（Container）の明確な分離
2. `TypeOf` による真のインターフェース判定
3. COM参照解放の徹底によるリークの根絶
このクラスを皆さんのコードライブラリに加え、Visio VBAの開発生産性を次元の違うレベルへと引き上げてください。
