概要：その一括画層変更、本当に「実務」に耐えうるか？
図面内の全オブジェクトの画層（レイヤ）を強制的に一括変更する――。
CADオペレーターであれば誰もが一度は直面する要件だ。しかし、思考停止で `SelectionSet` を回し、`Layer` プロパティを書き換えるだけのコードを書いてはいないだろうか？
もしそうなら、今すぐそのコードを捨ててほしい。
実務において、図面のトレーサビリティ（追跡可能性）は生命線だ。
「どのオブジェクトが、もともとのどの画層に所属していたのか」という履歴を保持しないまま画層を潰してしまうと、後工程での意図しない干渉チェックのミスや、設計変更時のリカバリー不能な手戻りを引き起こす。
今回は、AutoCAD VBAのオブジェクトモデルの挙動、メモリ管理、そして実務で求められる「元画層名の保持（トレーサビリティの確保）」を完璧に両立させる、プロダクションクオリティのコードを伝授する。
—
堅牢な設計のためのアーキテクチャ方針
実務で動くマクロを書くためには、以下の3点に妥協してはならない。
1. カスタムプロパティ（XData / カスタムプロパティ）の活用
元の画層名を失わないために、オブジェクト自体に拡張データ（XData）としてメタデータを埋め込む。これにより、図面ファイルが分かれても情報が欠落しない。
2. パフォーマンスとメモリリークの回避
AutoCAD VBAでは、解放すべきオブジェクト参照（特に `SelectionSet` や `Document`）を適切にハンドリングしないと、図面を開閉するうちにメモリリークを引き起こす。
3. エラーハンドリングとトランザクション的思考
ロックされた画層や、削除不可の画層、あるいはすでに存在しない画層へのアクセスに対して、コードがクラッシュしない堅牢性を持たせる。
—
プロダクションコード：元画層保持型・一括画層変更スクリプト
以下のコードは、現在のモデル空間（またはアクティブ空間）にある全エンティティを走査し、指定した新画層へ移動させつつ、元の画層名をAutoCADの拡張データ（XData）として各オブジェクトに刻み込む実務仕様のVBAスクリプトである。
Option Explicit
‘ 拡張データ（XData）で使用するアプリケーション名
Private Const APP_NAME As String = “ORIGINAL_LAYER_MGR”
Public Sub MigrateObjectsToNewLayer()
Dim acadDoc As AcadDocument
Set acadDoc = ThisDrawing.Application.ActiveDocument
‘ 1. 処理対象の新画層名を入力させる
Dim targetLayerName As String
targetLayerName = Trim(InputBox(“移動先の新しい画層名を入力してください:”, “画層一括移行”, “0”))
If targetLayerName = “” Then
MsgBox “処理がキャンセルされました。”, vbExclamation, “中断”
Exit Sub
End If
‘ 2. 存在チェック：新画層が図面に存在するか確認し、なければ作成する
If Not CheckOrCreateLayer(acadDoc, targetLayerName) Then
MsgBox “指定された画層を作成・取得できませんでした。”, vbCritical, “エラー”
Exit Sub
End If
‘ 3. XDataのレジストリ登録（必須）
acadDoc.RegApp APP_NAME
‘ 4. 処理の高速化と安定化のため、画面更新とイベントを一時停止
acadDoc.Application.ScreenUpdating = False
Dim ent As AcadEntity
Dim counter As Long
counter = 0
On Error GoTo ErrorHandler
‘ トランザクション的処理の開始（モデル空間／ペーパー空間の考慮）
Dim targetColl As AcadSelectionSet
Set targetColl = CreateSafeSelectionSet(acadDoc, “MIGRATE_SS”)
‘ データベース内の全エンティティを取得（ロック画層等も考慮するため空間全体をスキャン）
Dim activeSpace As AcadBlock
Set activeSpace = acadDoc.ActiveSpaceCollection ‘ 厳密にはActiveLayoutのBlock
‘ 実務的には ModelSpace または PaperSpace を明示的に指定する
Dim ms As AcadModelSpace
Set ms = acadDoc.ModelSpace
Dim originalLayer As String
‘ 5. エンティティのループ処理
For Each ent in ms
‘ 画層変更可能かチェック（ロックされているオブジェクトはスキップ等）
If Not ent.Layer = targetLayerName Then
‘ 【重要】元の画層名を控える
originalLayer = ent.Layer
‘ 拡張データ（XData）に元の画層名を書き込む
Call WriteOriginalLayerXData(ent, originalLayer)
‘ 新画層へ移動
ent.Layer = targetLayerName
counter = counter + 1
End If
Next ent
acadDoc.Application.ScreenUpdating = True
‘ 正常終了メッセージ
MsgBox “画層の移行が完了しました。” & vbCrLf & _
“移行先画層: ” & targetLayerName & vbCrLf & _
“処理オブジェクト数: ” & counter & “件”, vbInformation, “完了”
CleanUp:
‘ 6. 確実なオブジェクト解放（メモリリーク防止）
On Error Resume Next
If Not targetColl Is Nothing Then
targetColl.Delete
acadDoc.SelectionSets.Item(“MIGRATE_SS”).Delete
End If
acadDoc.Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
acadDoc.Application.ScreenUpdating = True
MsgBox “予期せぬエラーが発生しました: ” & Err.Description, vbCritical, “致命的エラー”
Resume CleanUp
End Sub
‘ ==========================================
‘ 補助関数群
‘ ==========================================
‘ 画層の存在確認と自動作成
Private Function CheckOrCreateLayer(doc As AcadDocument, layerName As String) As Boolean
Dim lyr As AcadLayer
On Error GoTo CreateNew
Set lyr = doc.Layers.Item(layerName)
CheckOrCreateLayer = True
Exit Function
CreateNew:
On Error GoTo ErrHandler
Set lyr = doc.Layers.Add(layerName)
CheckOrCreateLayer = True
Exit Function
ErrHandler:
CheckOrCreateLayer = False
End Function
‘ 安全なセレクションセットの作成（既存重複エラー回避）
Private Function CreateSafeSelectionSet(doc As AcadDocument, ssName As String) As AcadSelectionSet
Dim ss As AcadSelectionSet
On Error Resume Next
Set ss = doc.SelectionSets.Item(ssName)
If Not ss Is Nothing Then
ss.Delete
End If
Set ss = doc.SelectionSets.Add(ssName)
Set CreateSafeSelectionSet = ss
End Function
‘ オブジェクトへ元画層名をXDataとして書き込む
Private Sub WriteOriginalLayerXData(ent As AcadEntity, originalLayerName As String)
Dim dataType(0) As Integer
Dim dataValue(0) As Variant
‘ DXFグループコード 1000 は文字列を示す
dataType(0) = 1001: dataValue(0) = APP_NAME ‘ アプリケーション名定義
‘ 実際には拡張データ構造として AppName の後にデータをぶら下げる
Dim xDataType(0) As Integer
Dim xDataValue(0) As Variant
xDataType(0) = 1000 ‘ 文字列データ
xDataValue(0) = originalLayerName
ent.SetXData xDataType, xDataValue
End Sub
—
現場のエンジニアへ：コードの急所と応用
1. なぜ「レイヤ名」をそのままプロパティに持たせず XData なのか？
図面間でブロックを挿入したり、別図面へオブジェクトをコピペしたりする際、通常のカスタムプロパティ（DxfNameや単なる属性）は消失したり競合したりするリスクがある。
AutoCADのXData（拡張データ）は、エンティティのデータベースレコードに直接紐づくため、図面のコンバートや外部参照のバインドを行っても、データの整合性が極めて高く維持される。これが「プロフェッショナルな設計」だ。
2. パフォーマンスの最適化 (`ScreenUpdating = False`)
数万件のオブジェクトを含むパース図や配管図をループさせる際、AutoCADが毎回のプロパティ変更ごとに画面を描画（再描画）していると、処理が数分単位でフリーズする。
`ScreenUpdating = False` を挟むことで、バックグラウンドでの一括処理が可能になり、実行速度が劇的に向上する（※エラー時にも必ず `True` に戻す例外処理構造を忘れないこと）。
3. 次なるステップ：逆変換（元に戻す）の実装
このコードで保存したXDataを読み取り、オブジェクトを「元の画層にワンタッチで復元するスクリプト」を対として用意しておけば、設計者からの信頼は揺るぎないものになるだろう。読み出しには `GetXData` メソッドを使用する。
現場の生産性を上げるのは、場当たり的なマクロの継ぎ合わせではなく、「データ構造までデザインされた堅牢なコード」だ。ぜひ自身の開発環境に組み込んで、その圧倒的な安定性を体感してほしい。
