TOP PAGE > 記事閲覧
Excelにレイヤ名を取得、変更するVBA
投稿日 | : 2016/04/11(Mon) 19:32 |
投稿者 | : アルサポ |
参照先 | : http://r-support.org/bbs/tmp/sample03.xlsm |
今回もExcelのVBAを使ったプログラムを紹介したいと思います。
JDrafで開いている図面からレイヤ名を取得して、EXCELのA列に一覧を表示し、
変更後のレイヤ名をB列に入力していればJDrafに開いている図面のレイヤ名を変更するプログラムです。
プログラムが完成したExcelを「参照先」にリンクを貼っていますので、興味がある方はダウンロードして下さい。
まず、Excelの準備は、1行目のA列、B列には、それぞれ「取得レイヤ名」、「変更後レイヤ名」の項目名を入力して下さい。
最後に、ActiveXのボタンをそれぞれ「レイヤ名を取得」ボタン、「レイヤ名を変更」ボタンの2つを配置して下さい。
Excelの準備はこれで終わりです。VBEに書き込むプログラムコードは、次の投稿に記載します。
プログラムは参照設定が必要になるのでVBE(Visual Basic Editor)にて設定をして下さい。
「PCAD_AC_X Type Library」、「PCAD_DB_X 3.09 Type Library」の2つ必要が必要です。
参照設定の選択肢にない場合には、JDrafが32bit版を使っている場合は、
「PCAD_AC_X Type Library」が「C:\Program Files (x86)\JDraf Co Ltd\JDraf 2016\BIN\JDraf.exe」
「PCAD_DB_X 3.09 Type Library」が「C:\Program Files (x86)\JDraf Co Ltd\JDraf 2016\BIN\OdaX_3.09_11.dll」
JDrafが64bit版を使っている場合は、
「PCAD_AC_X Type Library」が「C:\Program Files\JDraf Co Ltd\JDraf 2016\BIN\JDraf.exe」
「PCAD_DB_X 3.09 Type Library」が「C:\Program Files\JDraf Co Ltd\JDraf 2016\BIN\OdaX_3.09_11.dll」
にファイルがあり、対応bitの違いで場所が違うので注意して下さい。
それと、OfficeとJDrafのbit数も同じでないと実行できないので、この点にも注意して下さい。
Re: VBEに貼り付けて下さい
投稿日 | : 2016/04/11(Mon) 19:33 |
投稿者 | : アルサポ |
参照先 | : |
Option Explicit
'VBA ウィンドウのツールメニューの参照設定から
'「PCAD_AC_X Type Library」と「PCAD_DB_X 3.09 Type Library」を選択する必要がある
Dim app As AcadApplication 'アプリケーションオブジェクト
Dim doc As AcadDocument 'アクティブなドキュメント
'「レイヤ名を取得」ボタン
Private Sub CommandButton1_Click()
On Error Resume Next
'JDrafを取得
Call getDocument
Dim i As Integer
For i = 0 To doc.Layers.Count - 1
Range("A" & i + 2).Value = doc.Layers.Item(i).Name
Next i
Set app = Nothing
Set doc = Nothing
MsgBox "レイヤ名を取得しました"
End Sub
'「レイヤ名を変更」ボタン
Private Sub CommandButton2_Click()
On Error Resume Next
'JDrafを取得
Call getDocument
Dim i As Long, lastRow As Long
'最終行を取得する
lastRow = Range("A1048576").End(xlUp).row
For i = 2 To lastRow
Dim oldLayer As String, newLayer As String 'oldLayer:変更前レイヤ名、newLayer:変更後レイヤ名
oldLayer = Range("A" & i).Value: newLayer = Range("B" & i).Value
'変更前、変更後、レイヤ名が同じまたは、変更後のレイヤ名が未入力であれば、何も処理しない
If oldLayer <> newLayer And newLayer <> "" Then
If doc.Layers(newLayer) Is Nothing Then '重複するレイヤをチェック
'変更後のレイヤが存在しない場合の処理
doc.Layers(oldLayer).Name = newLayer 'レイヤ名を変更
Else
Dim obj As AcadEntity
'変更後のレイヤが存在する場合の処理
For Each obj In doc.ModelSpace '今回はとりあえずモデル空間のみ対象
If obj.Layer = oldLayer Then obj.Layer = newLayer 'オブジェクトを変更後レイヤへ移動
Next obj
End If
End If
Next i
doc.PurgeAll '名前削除
doc.SendCommand "REGENALL" & vbLf 'コマンドを送ることも出来る(再作図)
Set app = Nothing
Set doc = Nothing
MsgBox "レイヤ名を変更しました"
End Sub
'JDrafを取得
Private Sub getDocument()
On Error Resume Next
Set app = GetObject(, "PCAD_AC_X.AcadApplication") '実行中のJDRAFを取得する
'実行中のJDRAFがなく、取得できないとき
If app Is Nothing Then
MsgBox "JDrafを起動して、再度実行して下さい。"
Exit Sub
End If
'アクティブな図面オブジェクトを取得
Set doc = app.ActiveDocument
End Sub
Re: Excelにレイヤ名を取得、変更するVBA
投稿日 | : 2016/04/11(Mon) 19:42 |
投稿者 | : アルサポ |
参照先 | : |
ざっくりとした説明としては、
レイヤ名を取得するプログラムは、図面で使われているレイヤをひとつずつ取得していく仕組みになっています。
レイヤ名を変更するプログラムの方は、変更後のレイヤ名が図面に存在しない場合にはレイヤ名(名前だけ)を変更して、
変更後のレイヤ名が存在する場合には変更後のレイヤにオブジェクトを移動する仕組みになっています。
レイヤ名を変更する場合、処理されるレイヤ数が多くても処理する時間は気になりにくいと思いますが、
変更後のレイヤにオブジェクトを移動する処理については、オブジェクトの数が多いほど時間がかかるので
何かいい仕組みがないか気になるところです。
最後にJDrafにコマンドを送る記述も今回使用しています。(doc.SendCommand "コマンドの内容" & vbLf)
これをもとに色々なコマンドを試してみても面白いのではないでしょうか?