Dim Acad
'Acad変数はErサブルーチンでも使うのでここで宣言
Call Main 'Mainサブルーチンコール
'図面内のすべての直線のX座標を50mm平行移動(ロック画層対応版)
Sub Main()
'AcadRemoconオブジェクト作成
Set Acad = CreateObject("AcadRemocon.Body")
'図面全体をDXFファイルに書き出し(ロック画層で描かれた図形も含む)
If Not Acad.acDxfOut("", "DWG") Then Er: Exit Sub
'DXFファイルからLINEオブジェクトを抽出(10=始点X座標のグループコード,11=終点X座標のグループコード)
If Not Acad.DxfExtract(Cnt, ExtArr, "ENTITIES", "", "LINE", "10|11") Then Er: Exit Sub
'抽出数が0なら終了
If Cnt = 0 Then Exit Sub
'始点と終点のX座標を50mmずらす
For i = 1 To Cnt: ExtArr(1, i) = ExtArr(1, i) + 50:
ExtArr(2, i) = ExtArr(2, i) + 50: Next
'配列への変更をDXFファイルに反映
If Not Acad.DxfUpdate(ExtArr) Then Er: Exit Sub
'DXFIN実行
If Not Acad.acDxfIn() Then Er: Exit Sub
'画層の状態を保存
If Not Acad.acSaveLayerState() Then Er: Exit Sub
'画層ロック解除(ロック画層で描かれた図形は削除出来ないので)
If Not Acad.acPostCommand("-LAYER U *^M^M") Then Er: Exit Sub
'直前の選択セットを削除
If Not Acad.acPostCommand("ERASE P^M^M") Then Er: Exit Sub
'画層の状態を復元
If Not Acad.acLoadLayerState() Then Er: Exit Sub
End Sub
'エラー処理
Sub Er()
'ユーザーによるキャンセル
If Acad.ErrNumber = vbObjectError + 1000 Then
'ここにキャンセル時の処理を追加
'
Else
'エラー内容表示
Acad.ShowError
End If
End Sub |