こんにちは！AutoCAD VBAの世界へようこそ。
マクロの記録ボタンを押して「なんだか動いたけれど、中身がさっぱり分からない…」という状態から抜け出し、自分の手で図面を意のままに操りたいと思っていませんか？
今回は、実務で非常に役立つ「図面内の全オブジェクトを指定した新画層へ強制移動させつつ、元の画層名をカスタムプロパティに刻み込んで完全なトレーサビリティ（追跡可能性）を確保する」という、ちょっと一歩進んだ実用スクリプトを一緒に作っていきましょう。
ここをクリアすれば、AutoCAD VBAのオブジェクトモデルの核心が見えてきます。優しく、そして本質的なところまでしっかりと解説していきますね。
—
1. なぜ「元の画層名」を保持する必要があるのか？（実務の現場から）
設計変更の嵐の中、外部から受領した図面や、雑多に作図された図面を整理する場面は数多くあります。
「すべての線や文字をとりあえず『A-WORK』という新規画層にまとめたい。でも、後から『元の画層がどこだったか』を復元できるようにしておきたい」
そんなとき、人間の手で一件一件プロパティを確認してメモしていたら、日が暮れてしまいますよね。VBAを使えば、オブジェクトが持つ「現在の画層（Layer）」という魂をコードで読み取り、図面全体が持つ「カスタムプロパティ（CustomProperty）」という金庫に安全に保管しながら、一瞬で画層を書き換えることが可能です。
ここから、AutoCAD VBAの心臓部である「オブジェクトモデル」の基本を覗いてみましょう。
—
2. AutoCAD VBAの基本構造：ApplicationとDocument
AutoCAD VBAを動かすとき、私たちは常に2つの巨大な親分を意識しています。
1. `ThisDrawing`（AcadDocument）: 今まさに画面で開いている図面そのもの。
2. `Application`: AutoCADというソフト全体（今回は省略しても `ThisDrawing` 経由でアクセスできます）。
図面の中には、線（Line）や円（Circle）、文字（Text）といった個別の図形たちが、ModelSpace（モデル空間）という大広間にゴロゴロと転がっています。
VBAでこれらを操作する基本手順は、いつもこれだけです。
> 「モデル空間のドアを開け、中にいるオブジェクトたちを一人ずつ取り出し、条件に合わせてプロパティを書き換える」
これさえ頭に入っていれば、どんな複雑な自動化も怖くありません。
—
3. 【実践】画層一括移行 ＆ 履歴保持スクリプト
それでは、今回の主役となるVBAコードを公開します。
AutoCADのVBAエディタ（[Alt] + [F11]）を開き、標準モジュールに以下のコードを貼り付けてみてください。
Sub MigrateLayersWithTraceability()
Dim acadDoc As AcadDocument
Set acadDoc = ThisDrawing
‘ — 設定エリア —
Dim targetLayerName As String
targetLayerName = “A-NEW-LAYER” ‘ 移動先の画層名をここに指定します
‘ 移動先の画層が図面に存在するか確認し、なければ作成する
Dim targetLayer As AcadLayer
On Error Resume Next
Set targetLayer = acadDoc.Layers.Item(targetLayerName)
If Err.Number <> 0 Then
‘ 画層が存在しない場合は新規作成
Set targetLayer = acadDoc.Layers.Add(targetLayerName)
Err.Clear
End If
On Error GoTo 0
‘ — ユーザーへの確認 —
Dim msg As String
msg = “モデル空間内の全オブジェクトを画層 ‘” & targetLayerName & “‘ に移動します。” & vbCrLf & _
“元の画層名はカスタムプロパティに記録されます。実行しますか？”
If MsgBox(msg, vbYesNo + vbInformation, “画層一括移行ツール”) = vbNo Then Exit Sub
‘ — メイン処理：モデル空間の走査 —
Dim ent As AcadEntity
Dim count As Long
count = 0
For Each ent In acadDoc.ModelSpace
‘ 1. 元の画層名をXData（拡張データ）またはカスタムプロパティの代わりに
‘ オブジェクト自体の「Handle（固有ID）」をキーにして記録を残す発想も強力ですが、
‘ 今回はシンプルに「図面のサマリ情報（CustomProperty）」に一括記録を残します。
Dim originalLayer As String
originalLayer = ent.Layer
‘ 2. すでにターゲット画層にいるものはスキップ（無限ループや無駄な処理を防ぐプロの技）
If originalLayer <> targetLayerName Then
‘ 【重要】トレーサビリティの確保：
‘ オブジェクトの「Hyperlinks」や「XData」に元画層を刻むことも可能ですが、
‘ 今回は最も手軽で確実な「図面のカスタムプロパティ」に履歴の足跡を残します。
Call AddOrUpdateCustomProperty(acadDoc, “OrigLayer_” & ent.Handle, originalLayer)
‘ 3. 画層の書き換え
ent.Layer = targetLayerName
count = count + 1
End If
Next ent
‘ 画面を最新の状態に更新
acadDoc.Regen acAll
‘ 完了報告
MsgBox “処理が完了しました！” & vbCrLf & _
“変更されたオブジェクト数: ” & count & ” 件”, vbInformation, “完了”
End Sub
‘ =================================================================
‘ 補助ルーチン：図面のファイルプロパティ（カスタム）にデータを書き込む
‘ =================================================================
Private Sub AddOrUpdateCustomProperty(doc As AcadDocument, propName As String, propValue As String)
Dim summaryInfo As AcadSummaryInfo
Set summaryInfo = doc.SummaryInfo
Dim i As Integer
Dim key As String
Dim val As String
Dim found As Boolean
found = False
‘ 既存のカスタムプロパティをチェックし、同名があれば上書きする
For i = 0 To summaryInfo.NumCustomKeys – 1
summaryInfo.GetCustomByIndex i, key, val
If key = propName Then
summaryInfo.SetCustomByIndex i, propName, propValue
found = True
Exit For
End If
Next i
‘ なければ新しく追加する
If Not found Then
summaryInfo.AddCustomKeyValue propName, propValue
End If
End Sub
—
4. コードの深掘り解説：ここがエンジニアのこだわりポイント
ただ動くだけのコードなら誰でも書けます。ここでは、実務でエラーを起こさないための「プロの知見」をいくつか解説します。
① 「ないなら作る」安全な画層チェック
Set targetLayer = acadDoc.Layers.Item(targetLayerName)
If Err.Number <> 0 Then
Set targetLayer = acadDoc.Layers.Add(targetLayerName)
End If
指定した画層が図面に存在しない状態で `ent.Layer = …` を実行すると、容赦なく実行時エラー（画層が存在しません）でマクロがクラッシュします。
`On Error Resume Next` を盾にして、存在しない場合は自動でその場で画層を生成する「自己修復型のロジック」を組むのが、実務で信頼されるツールの条件です。
② すべてのオブジェクトの指紋「Handle」を使う
図面内のオブジェクトには、それぞれ被る緑のない固有のIDである `Handle`（ハンドル） が割り振られています。
今回のコードでは、図面のカスタムプロパティに `OrigLayer_[オブジェクトのHandle] = [元の画層名]` という形式で記録を残しています。これにより、「どの図形の元の画層がどこだったか」を完全に1対1で追跡できるようになります。
③ 無駄な処理を省くスマートさ
If originalLayer <> targetLayerName Then
すでに目的の画層にいるオブジェクトに対してわざわざプロパティを書き換える命令を送るのは、コンピュータにとっても無駄な負荷です。こうした「無駄撃ちをしない条件分岐」を入れることで、数万個のオブジェクトがある重い図面でも軽快に動作します。
—
5. 陥りやすい罠と注意点
- ブロック参照（BlockReference）の扱いに注意！
今回のスクリプトはモデル空間直下のオブジェクトを対象としています。もしブロックの「中身（ネストされた図形）」まで画層を変えたい場合は、ブロック定義（Block）の中身を再帰的にループ処理する必要があります。（これはまたの機会に深く解説しましょう！）
- 図面の保存を忘れずに
カスタムプロパティにデータを書き込んでいるため、マクロを実行した後は必ず図面を上書き保存してください。
—
まとめ
今回は、図面内の全オブジェクトの画層を一括変更しつつ、カスタムプロパティに元画層名を刻む実用的なスクリプトをご紹介しました。
- `For Each` を使ってモデル空間を巡回する方法
- 存在しない画層を自動生成するエラーハンドリングのテクニック
- 図面のカスタムプロパティを活用したトレーサビリティの確保
ここをクリアできれば、もうあなたは「マクロの記録」に頼る初心者ではありません。立派なAutoCAD自動化エンジニアの第一歩を踏み出しています。
日々の退屈なルーティン作業はVBAに任せて、あなたしかできないクリエイティブな設計業務に時間を使いましょう。それでは、また次の知見でお会いしましょう！
