なぜ、あなたのVisio VBAは数千個のシェイプ描画で停止するのか
Visio VBAで大量の図形（シェイプ）を自動生成するツールを構築した際、描画個数が数百〜数千件を超えたあたりで処理が劇的に重くなり、最悪の場合はVBAが応答なし（フリーズ）になる現象に直面したことはないでしょうか。
その原因の9割は、「`Shape.Copy` と `Page.Paste`（クリップボード経由の操作）」に依存した実装にあります。
画面上の見た目をそのままコード化する初級者のアプローチは、小規模なプロトタイプでは機能します。しかし、何千ものオブジェクトを扱うプロダクション環境では、この手法は致命的なパフォーマンスボトルネックと不確定なバグを引き起こします。
本記事では、Visio内部のオブジェクトモデル（Application/Document/Page/Shape）のライフサイクルを考慮し、クリップボードを完全にバイパスしてメモリ効率を最適化する複製アルゴリズム（`Drop` / `DrawPolyline` / `DropMany`）を伝授します。
—
1. アンチパターン：Copy/Pasteが引き起こす3つの悲劇
なぜ `Copy` / `Paste` を使ってはいけないのか。単に「遅いから」ではありません。システムアーキテクチャの観点から明確な3つのリスクが存在します。
【従来の非効率なアプローチ（クリップボード経由）】
Visio Shape ──> Windows Clipboard (OS I/O) ──> Visio Page
▲ 外部プロセスからの競合リスク
▲ Selectionオブジェクトの同期オーバーヘッド
▲ メモリ空間の連続再確保による低速化
① OSレベルのクリップボード競合
`Copy` 操作は、Windowsのグローバルクリップボードを占有します。これにより、以下の問題が不可避となります。
- ユーザーがバックグラウンドで操作した `Ctrl + C` との不整合。
- クリップボードを監視する常駐ソフト（Cliborやセキュリティソフト等）によるプロセスロック。
- COM例外（`0x800401D0 (CLIPBRD_E_CANT_OPEN)`）の発生。
② Selectionオブジェクトの暗黙生成と描画負荷
`Page.Paste` は、貼り付けたオブジェクトを自動的にアクティブな「Selection（選択状態）」にします。Visio内部では、選択枠の再描画、アンカーポイントの計算、UIイベントの発行が都度発生し、計算量が $O(N^2)$ に跳ね上がります。
③ COMオブジェクトの解放漏れとメモリの断片化
クリップボードを経由するたびに、OSとVisioの境界でマーシャリング（データ変換）が行われ、一時的なオブジェクト構造がメモリ上に無数に構築されます。これがガベージコレクションを圧迫し、メモリの断片化を引き起こします。
—
2. 脱・クリップボード：3つの高速化アプローチ
クリップボードを経由せずにシェイプを生成・複製する手法は、用途に応じて大きく3つに分類されます。
| 手法 | 特徴 | 適用ユースケース | 描画速度 |
| :— | :— | :— | :— |
| `Page.Drop` | 既存シェイプやマスターを直接指定位置にインスタンス化 | 複雑なShapeSheet属性を持つ標準図形の複製 | ★★★☆☆ |
| `Page.DrawPolyline` | 幾何ベクターデータ（座標配列）からダイレクト描画 | 境界線、配線、単純なフレーム、大量のポリライン | ★★★★☆ |
| `Page.DropMany` | 配列に格納したマスターと座標を一括投入（バッチ処理） | ネットワーク構成図、ラック図面、大規模系統図の大量配置 | ★★★★★ |
① `Page.Drop` メソッド
既存の `Shape` オブジェクト、またはステンシル内の `Master` オブジェクトを指定した $(X, Y)$ 座標へ直接複製します。クリップボードを一切汚染せず、Selection状態も変更しません。
‘ 既存シェイプ（targetShape）を座標 (x, y) に複製
Dim newShape As Visio.Shape
Set newShape = TargetPage.Drop(targetShape, x, y)
② `Page.DrawPolyline` メソッド
図形の外観が線分や単純な多角形である場合、ShapeSheet構造を持つシェイプを大量にDropするよりも、直線の頂点座標配列（Double型の配列）から幾何形状を直描する方がはるかに高速です。
‘ 座標配列から直接ポリラインを高速生成
Dim points(0 To 9) As Double ‘ (x1,y1) ～ (x5,y5)
‘ 座標のセット…
Dim polyShape As Visio.Shape
Set polyShape = TargetPage.DrawPolyline(points, visvisBBoxDrawing, 0)
③ `Page.DropMany` メソッド（極限のパフォーマンス）
VBAとVisioプロセス間のCOM呼び出し（RPC）のオーバーヘッドを削減する究極の手法です。1,000回の `Drop` 呼び出し（COM呼び出し1,000回）を、1回の `DropMany`（COM呼び出し1回） に集約します。
—
3. プロダクションコード：1,000個のシェイプを瞬時に生成する実装
以下は、実務でそのまま利用できる堅牢なプロダクションコードです。
画面描画の抑制（`ScreenUpdating`）、数式計算の遅延（`DeferRecalc`）、Undoバッファの抑制（`UndoScope`）を完全に制御した構造になっています。
標準モジュール：`mod_ShapeReplicator.bas`
Attribute VB_Name = “mod_ShapeReplicator”
Option Explicit
‘ ==============================================================================
‘ 概要: クリップボードを経由せずに、指定したソースシェイプを大量複製する
‘ 引数:
‘ sourceShape : 複製元となるVisioシェイプオブジェクト
‘ count : 複製する個数
‘ cols : グリッド配置時の列数
‘ spacingX : 横方向の間隔 (インチまたは内部単位)
‘ spacingY : 縦方向の間隔 (インチまたは内部単位)
‘ ==============================================================================
Public Sub ReplicateShapesHighPerformance( _
ByRef sourceShape As Visio.Shape, _
ByVal count As Long, _
ByVal cols As Long, _
ByVal spacingX As Double, _
ByVal spacingY As Double)
On Error GoTo ErrorHandler
If sourceShape Is Nothing Then
Err.Raise vbObjectError + 513, “ReplicateShapesHighPerformance”, “ソースシェイプがNothingです。”
End If
If count <= 0 Or cols <= 0 Then Exit Sub
Dim app As Visio.Application
Set app = Visio.Application
Dim targetPage As Visio.Page
Set targetPage = sourceShape.ContainingPage
' --------------------------------------------------------------------------
' 1. パフォーマンス最適化フラグの設定（極めて重要なライフサイクル制御）
' --------------------------------------------------------------------------
Dim originalScreenUpdating As Boolean
Dim originalDeferRecalc As Boolean
Dim undoScopeID As Long
originalScreenUpdating = app.ScreenUpdating
originalDeferRecalc = app.DeferRecalc
app.ScreenUpdating = False ' 画面描画を停止
app.DeferRecalc = True ' ShapeSheetの即時計算を延期
' アンドゥスコープを開き、一連の操作を1つのUndoとして統合（メモリ節約）
undoScopeID = app.BeginUndoScope("Mass Shape Replication")
' --------------------------------------------------------------------------
' 2. DropMany用配列の確保（一括バッチ処理の準備）
' --------------------------------------------------------------------------
' DropManyに必要な各種配列の宣言
Dim objectsToDrop() As Variant
Dim xyArray() As Double
Dim droppedShapeIDs() As Long
ReDim objectsToDrop(0 To count - 1)
ReDim xyArray(0 To (count 2) - 1)
' 基準座標の取得（ソースシェイプの初期位置）
Dim startX As Double, startY As Double
startX = sourceShape.Cells("PinX").ResultIU
startY = sourceShape.Cells("PinY").ResultIU
Dim i As Long
Dim colIndex As Long, rowIndex As Long
Dim currentX As Double, currentY As Double
For i = 0 To count - 1
' 複製元オブジェクトとしてソースシェイプを設定
Set objectsToDrop(i) = sourceShape
' 配置座標の計算（グリッド配置）
colIndex = i Mod cols
rowIndex = i \ cols
currentX = startX + (colIndex spacingX)
currentY = startY - (rowIndex spacingY) ' 下方向へ配置
xyArray(i 2) = currentX
xyArray(i 2 + 1) = currentY
Next i
' --------------------------------------------------------------------------
' 3. DropMany実行（COMオーバーヘッドを最小化する一括展開）
' --------------------------------------------------------------------------
Call targetPage.DropMany(objectsToDrop, xyArray, droppedShapeIDs)
' 必要に応じて、返された droppedShapeIDs を使用しテキストやプロパティを一括更新可能
CleanExit:
' --------------------------------------------------------------------------
' 4. リソースの安全な復元とクリーンアップ
' --------------------------------------------------------------------------
On Error Resume Next
If undoScopeID <> 0 Then app.EndUndoScope undoScopeID, True
app.DeferRecalc = originalDeferRecalc
app.ScreenUpdating = originalScreenUpdating
Exit Sub
ErrorHandler:
Dim errDesc As String
errDesc = Err.Description
‘ エラー時もUndoスコープを閉じて変更をロールバックする
If undoScopeID <> 0 Then app.EndUndoScope undoScopeID, False
app.DeferRecalc = originalDeferRecalc
app.ScreenUpdating = originalScreenUpdating
MsgBox “シェイプ複製処理中にエラーが発生しました: ” & errDesc, vbCritical, “エラー”
Resume CleanExit
End Sub
—
4. DB・外部ファイル連携時の注意点と運用ノウハウ
CSVやデータベース（SQL Server / Access等）から読み込んだ数千件のデータを基に動的にVisio図面を生成する場合、さらなるボトルネックが発生します。それが 「ShapeSheetセルへの個別書き込み（`CellsSR` / `Cells`）」 です。
図形を複製した後に、1つずつセルへテキストやプロパティを書き込む処理を行うと、速度低下が発生します。
‘ 【アンチパターン】1セルずつ書き込むと、COMの呼び出し回数が爆発する
shp.Cells(“Prop.ID”).Formula = “””” & rowID & “”””
shp.Cells(“Text”).Formula = “””” & rowName & “”””
解決策：`SetFormulas` によるセルの一括評価
`DropMany` で生成されたシェイプ群に対し、テキストやカスタムプロパティを代入する際は、Visio 2013以降で最適化されている `SetFormulas` メソッドを使用します。
‘ 【プロダクション標準】セルパスと数式配列を渡し、一括設定する
Dim SIDSRC() As Integer
‘ 構造: [ShapeID, Section, Row, Column] の2次元配列を作成し
‘ targetPage.SetFormulas SIDSRC, formulaArray, 0 で一括評価させる
これにより、データベースからの大容量インポート処理においても、「データの全件読み込み → `DropMany` で一括描画 → `SetFormulas` で属性一括適用」 という完全に最適化されたパイプラインが完成します。
—
5. まとめ：アーキテクトとしての心得
Visio VBA開発において、「動くコード」と「プロダクションで耐えうるコード」の境界線は、VisioオブジェクトモデルとCOMの通信コストを理解しているか にあります。
- `Copy` / `Paste` は原則禁止。クリップボードはユーザーのものであり、VBAの内部データ転送領域ではない。
- 基本は `Page.Drop`。インスタンス化のコストを抑え、Selectionの同期描画を回避する。
- 超大量データ（数千件超）には `Page.DropMany`。COMのラウンドトリップを最小化し、バッチ処理で描画させる。
- 状態管理の徹底。`ScreenUpdating` や `DeferRecalc` は、必ず `Try…Finally`（VBAでは `On Error GoTo Cleanup`）の文脈で元に戻す構造を担保する。
この原則を守ることで、あなたの構築するVisio自動化システムは、データ規模が拡大しても一切破綻しない堅牢性と圧倒的なパフォーマンスを発揮します。
