【実務・中級編】【実務中級者向け】図面保存時に「特定の機密画層」を自動削除して社外配布用DWGを作成するセキュリティマクロ – AutoCAD VBA解析バイブル

破壊的変更を避ける設計思想：図面セキュリティ自動化における「Copy-and-Sanitize」パターン

実務において「社外配布用の図面作成」を自動化するタスクは、一見すると単純な「レイヤー削除と保存」に見える。しかし、多くの開発者がここで致命的な設計ミスを犯す。

もし君が、現在開いている図面（ActiveDocument）に対して直接レイヤー削除を実行し、その後に `SaveAs` を試みるという実装を考えているなら、今すぐその設計書を破棄すべきだ。

なぜか？ 理由は明白だ。
もしレイヤー削除の途中でエラーが発生したら？ `Undo` で元に戻せると考えているのか？ AutoCADの `Undo` は、複雑なデータベース操作、特にオブジェクトの削除が絡むと、意図しない副作用（メモリリークや図面データベースの不整合）を引き起こすリスクがある。何より、「作業中のオリジナル図面」を破壊するリスクを、プログラムに背負わせてはならない。

本記事では、プロフェッショナルが採用すべき、堅牢かつ安全な「Copy-and-Sanitize（コピーして浄化する）」パターンについて解説する。

1. 設計の核心：ステート（状態）の分離

プロフェッショナルな自動化エンジニアは、常に「副作用」を最小限に抑える設計を行う。今回の要件における正解は、以下のワークフローだ。

1. ファイルレベルの複製: 現在の図面ファイルを、OSレベルで一時的な作業用ファイルとしてコピーする。
2. 隔離された環境での操作: コピーしたファイルを `Documents.Open` で開き、その「コピーされたドキュメント」に対してのみ、機密レイヤーの削除を実行する。
3. 完全な浄化（Purge）: レイヤーを消しただけでは、メモリ上やデータベース内に「ゴミ」が残る。`PURGE` コマンドを呼び出し、完全にクリーンな状態にする。
4. 確定と破棄: 完成したファイルを指定のパスに `SaveAs` し、作業用ファイルは閉じる。

この設計により、万が一マクロがクラッシュしても、ユーザーが現在開いているオリジナル図面には、1ビットの変更も加わらない。 これが「堅牢な設計」の定義だ。

2. 実装における技術的難所

実装にあたり、以下の3点に注意せよ。

A. レイヤー削除の順序

レイヤーを削除するには、そのレイヤー上に存在するすべてのオブジェクトを先に削除しなければならない。AutoCADのデータベース制約により、オブジェクトが残っているレイヤーは削除不可だ。

B. Purge（浄化）の実行

VBAの `Purge` メソッドは非常に限定的だ。実務レベルのクリーンアップを行うには、`SendCommand` を用いてコマンドラインから `PURGE` を実行させるのが最も確実で、かつ「空のレイヤー」や「空のブロック定義」を根こそぎ排除できる。

C. ファイルシステムの制御

`FileSystemObject` (FSO) を使用し、保存先ディレクトリの存在確認や、同名ファイルの上書き制御をロジカルに行う必要がある。

3. プロダクション・コード例

以下に、そのまま実務のモジュールとして組み込めるレベルのコードを示す。

Option Explicit

' ==============================================================================
' Module: SecuritySanitizer
' Description: 特定の機密レイヤーを排除した配布用DWGを安全に生成する
' Author: Chief Architect
' ==============================================================================

Public Sub CreateExportDrawing()
    On Error GoTo ErrorHandler

    ' --- 設定エリア ---
    Dim confidentialLayers As Variant
    confidentialLayers = Array("SECRET_DATA", "CLIENT_INFO", "COST_LAYER") ' 削除対象レイヤー名
    
    Dim exportFolder As String
    exportFolder = "C:\Export_DWG\" ' 出力先フォルダ
    ' ------------------

    Dim acadApp As AcadApplication
    Set acadApp = ThisDrawing.Application

    Dim sourceDoc As AcadDocument
    Set sourceDoc = ThisDrawing.Document

    ' 1. 出力先フォルダの存在確認
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(exportFolder) Then
        MsgBox "出力先フォルダが存在しません: " & exportFolder, vbCritical
        Exit Sub
    End If

    ' 2. 元ファイルを一時ファイルとしてコピー (Copy-and-Sanitizeの肝)
    Dim tempFilePath As String
    tempFilePath = exportFolder & "TEMP_" & fso.GetFileName(sourceDoc.FullName)
    
    ' 既存のTempがあれば削除
    If fso.FileExists(tempFilePath) Then fso.DeleteFile tempFilePath
    fso.CopyFile sourceDoc.FullName, tempFilePath

    ' 3. コピーしたファイルを新しいドキュメントとして開く
    Dim targetDoc As AcadDocument
    Set targetDoc = acadApp.Documents.Open(tempFilePath)

    ' 4. 機密情報の抹消プロセス
    Debug.Print "Sanitizing: " & targetDoc.Name
    SanitizeDocument targetDoc, confidentialLayers

    ' 5. 保存とクリーンアップ
    Dim finalFileName As String
    finalFileName = exportFolder & "EXPORT_" & fso.GetBaseName(sourceDoc.FullName) & ".dwg"
    
    ' 同名ファイルがあれば削除（上書き準備）
    If fso.FileExists(finalFileName) Then fso.DeleteFile finalFileName
    
    targetDoc.SaveAs finalFileName
    targetDoc.Close
    
    ' 一時ファイルの削除
    fso.DeleteFile tempFilePath

    MsgBox "配布用ファイルが正常に生成されました:" & vbCrLf & finalFileName, vbInformation
    Exit Sub

ErrorHandler:
    MsgBox "致命的なエラーが発生しました。" & vbCrLf & _
           "Error No: " & Err.Number & vbCrLf & _
           "Description: " & Err.Description, vbCritical
    ' エラー時、開いたままのtargetDocがあれば閉じる処理が必要（設計上の配慮）
    If Not targetDoc Is Nothing Then targetDoc.Close False
End Sub

''' <summary>
''' 指定されたレイヤーおよびその上のオブジェクトを完全に抹消する
''' </summary>
Private Sub SanitizeDocument(doc As AcadDocument, layersToDelete As Variant)
    Dim i As Integer
    Dim layerName As Variant
    Dim targetLayer As AcadLayer
    Dim obj As AcadEntity
    Dim sset As AcadSelectionSet

    ' 1. 指定レイヤー上のオブジェクトをすべて削除
    For Each layerName In layersToDelete
        On Error Resume Next ' レイヤーが存在しない場合はスキップ
        Set targetLayer = doc.Layers.Item(CStr(layerName))
        On Error GoTo 0
        
        If Not targetLayer Is Nothing Then
            ' 選択セットを使用して、そのレイヤーに属するオブジェクトを高速に取得
            On Error Resume Next
            doc.SelectionSets.Item("SS_TEMP").Delete
            On Error GoTo 0
            Set sset = doc.SelectionSets.Add("SS_TEMP")
            
            ' フィルタリング（レイヤー名指定）
            Dim filterType(0) As Integer
            Dim filterData(0) As Variant
            filterType(0) = acLayerName
            filterData(0) = layerName
            
            sset.Select acSelectionSetAll, , , filterType, filterData
            
            ' オブジェクトの削除
            If sset.Count > 0 Then
                For i = sset.Count - 1 To 0 Step -1
                    sset.Item(i).Delete
                Next i
            End If
            sset.Delete
            
            ' 2. レイヤー自体の削除
            targetLayer.Delete
            Set targetLayer = Nothing
        End If
    Next layerName

    ' 3. PURGEによるデータベースの完全浄化
    ' VBAからでは不完全なため、SendCommandを使用してコマンドラインから実行
    doc.SendCommand "_PURGE" & vbCrLf & "*" & vbCrLf & "N" & vbCrLf & vbCrLf
    
    Debug.Print "Sanitization Complete."
End Sub

4. 結言：エンジニアとしての矜持

このコードが、単なる「レイヤー削除マクロ」と一線を画している点は、「失敗しても元の業務を止めない」というリスクマネジメントがコードの構造そのものに組み込まれている点だ。

実務における自動化ツールは、ユーザーの「作業」を助けるためのものであり、ユーザーの「資産（図面）」を脅かすものであってはならない。`ActiveDocument` を直接いじるという安易な道を選ばず、ファイルシステムとドキュメントのライフサイクルを制御する。これこそが、中級者を脱し、アーキテクトへと昇り詰めるための思考プロセスである。

「動けばいい」のではない。「壊れない設計」を書け。 次回の開発でも、この原則を忘れないことだ。