画層編集、２回目です。
とりあえず、下記の処理はできるようになりました。
１．画層の追加。
２．図形の種類ごとに画層を変更。
３．未使用の画層削除。
↓画層変更テストに使用したデータ（2000形式のDXF）
ブロック定義がなかったので、左下にブロックを作成しました。
↓画層変更前
（もう少し、画層を用意しておけば良かったかな。）
↓画層変更後
画層変更できてはいるけど、まだまだ実用には遠い。
数日前の記事で下記コードが失敗するけど
理由が分からない。と言った件ですが、
━─━─━─━─━─━─━─━─━─━─
Set acColor = GetInterfaceObject("AutoCAD.AcCmColor.18")
━─━─━─━─━─━─━─━─━─━─
コードを、
━─━─━─━─━─━─━─━─━─━─
Set acColor = gAcadDocs.Application.GetInterfaceObject("AutoCAD.AcCmColor.18")
━─━─━─━─━─━─━─━─━─━─
に、修正したら必ず成功するようになりました。
（修正したコードは回りくどいやり方です。）
どうも、
GetInterfaceObject が適用されるオブジェクトを
指定する必要があったようです。
（Helpに載ってました。）
最後に、テストに使用したソース掲載しておきます。
（見難くて、ごめんなさい。）
実行は、自己責任でお願いします。
━─━─━─━─━─━─━─━─━─━─
Option Explicit
'**********************************************
'DXF-DWG TEST
'**********************************************
Dim gAcadDocs As AcadDocument
Const 層0 As String = "0"
Const 層線 As String = "線"
Const 層円 As String = "円"
Const 層文字 As String = "文字"
Const 層寸法 As String = "寸法"
Const 層ブロック挿入 As String = "ブロック挿入"
Const 層その他 As String = "その他"
'**********************************************
'DXFTEST
'**********************************************
Private Sub DXFTEST()
On Error Resume Next
Dim dxfFiles As Variant
Dim fileName As Variant
Dim savefname As String
Dim AppObj As AcadApplication 'アプリケーションオブジェクト宣言
dxfFiles = Application.GetOpenFilename("DXFファイル (*.dxf),*.dxf", 0, "DXFファイル選択", , True)
If TypeName(dxfFiles) = "Boolean" Then
MsgBox "DXFファイルの選択を中止しました。", vbOKOnly + vbExclamation, "お知らせ"
Exit Sub
End If
'実行中のAutoCADアプリケーションオブジェクトの取得
Set AppObj = GetObject(, "AutoCAD.Application.18") '
If Err Then
'新規AutoCADアプリケーションオブジェクトの作成（起動）
Set AppObj = CreateObject("AutoCAD.Application.18")
End If
On Error GoTo 0
AppObj.Visible = True 'これがないと表示されない。
For Each fileName In dxfFiles
Set gAcadDocs = AppObj.Documents.Open(fileName) '選択したファイルを開く
Call 画層追加(層線, acRed)
Call 画層追加(層円, acYellow)
Call 画層追加(層文字, acGreen)
Call 画層追加(層寸法, acCyan)
Call 画層追加(層ブロック挿入, acBlue)
Call 画層追加(層その他, acMagenta)
Call 画層変更
'拡張子を除く
savefname = Mid(fileName, 1, InStrRev(fileName, ".", -1, vbTextCompare) - 1)
Call gAcadDocs.SaveAs(savefname, ac2007_dwg) 'ドキュメントを保存する
gAcadDocs.Close 'ドキュメントを閉じる
Next
AppObj.Quit 'AutoCAD終了
Set AppObj = Nothing 'オブジェクトの解放
End Sub
'**********************************************
'画層追加
'**********************************************
Public Sub 画層追加(画層名 As String, 色 As Integer)
Dim templayer As AcadLayer
Dim acColor As AcadAcCmColor
Set acColor = gAcadDocs.Application.GetInterfaceObject("AutoCAD.AcCmColor.18")
acColor.ColorMethod = acColorMethodByACI
acColor.ColorIndex = 色
Set templayer = gAcadDocs.Layers.Add(画層名) '画層追加
templayer.TrueColor = acColor
Set acColor = Nothing
End Sub
'**********************************************
'画層変更
'**********************************************
Public Sub 画層変更()
Dim ブロック名 As String
Dim templayer As AcadLayer
Dim acObj As AcadEntity
Dim blockObj As AcadBlock
Dim y As Long
ThisWorkbook.Worksheets(1).Cells.Clear
ThisWorkbook.Worksheets(2).Cells.Clear
'画層のロックを解除
For Each templayer In gAcadDocs.Layers
templayer.Lock = False
Next
y = 1
'ModelSpaceの図形の画層を変更する
For Each acObj In gAcadDocs.ModelSpace
Select Case TypeName(acObj)
Case "IAcadLine"
acObj.Layer = 層線
Case "IAcadCircle"
acObj.Layer = 層円
Case "IAcadText"
acObj.Layer = 層文字
'長さ、平行、直径、半径寸法
Case "IAcadDimRotated", "IAcadDimAligned", "IAcadDimDiametric", "IAcadDimRadial"
acObj.Layer = 層寸法
Case "IAcadBlockReference"
acObj.Layer = 層ブロック挿入
Case Else
acObj.Layer = 層その他
End Select
'図形タイプ名を記録する
ThisWorkbook.Worksheets(1).Cells(y, 1).Value = TypeName(acObj)
y = y + 1
Next
y = 1
'ブロック定義の画層変更
For Each blockObj In gAcadDocs.Blocks
'ブロック名を記録する
ThisWorkbook.Worksheets(2).Cells(y, 1).Value = blockObj.Name
y = y + 1
ブロック名 = UCase(blockObj.Name)
If ブロック名 <> "*MODEL_SPACE" And ブロック名 <> "*PAPER_SPACE" Then
For Each acObj In blockObj
acObj.Layer = 層0
ThisWorkbook.Worksheets(2).Cells(y, 2).Value = TypeName(acObj)
y = y + 1
Next
End If
Next
'現在の画層を"0"とする
gAcadDocs.ActiveLayer = gAcadDocs.Layers.Item(層0)
'未使用の画層を削除する
gAcadDocs.Layers.GenerateUsageData '画層状態データ更新
For Each templayer In gAcadDocs.Layers
If templayer.Used = False Then
templayer.Delete
End If
Next
End Sub
━─━─━─━─━─━─━─━─━─━─