Egg's Blog

C : ADT Tips

●ADT メニューのコピー

ADTのメニューを別名にし
オリジナルメニューを作成しようとした。

ところが、、、アイコンが化けてしまう。

オリジナルのメニューをコピーするには

ADT.cui、ADT.mnl、ADT.dll　の３つが必要！

これらを３つをコピーし、名前を変更

後は、オプションの「カスタマイズファイル」を変更する

C : VBA

●ExcelからAutoCADの操作

Excel VBAからAutoCADのライブラリを参照する

VBEditerで [ツール]－[参照設定]
AutoCAD 2006 Type Library ライブラリにチェック

'AutoCAD起動用関数________________________________

Public AcadApp As AcadApplication

Function acad_int()
On Error Resume Next

Set AcadApp = GetObject(, "AutoCAD.Application.16")'AutoCADヴァージョン

If Err Then
    Set AcadApp = CreateObject("AutoCAD.Application.16")
    AcadApp.Visible = True
End If

AcadApp.Visible = True

End Function

'現在の図面 又は 新規図面 ______________________________

Sub toAutoCAD()
On Error Resume Next

acad_int 'AutoCADの起動

Dim AcadDoc As AcadDocument

Set AcadDoc = AcadApp.ActiveDocument '現在アクティブな図面

If AcadDoc Is Nothing Then
    Set AcadDoc = AcadApp.Documents.Add("acadiso.dwt") '新規図面
End If

'以降 AutoCAD VBA 時の「Thisdrawing」 の代わりに「AcadDoc」を適用
'.
'.
'.処理後はメモリーリリース
    Set AcadDoc = Nothing
    Set AcadApp = Nothing
End Sub

C : VBA

●Excelへの書出し

Excelのライブラリを参照する

VBEditerで [ツール]－[参照設定]

Excel Object ライブラリにチェック！

_________________________________________
プログラムのながれ
１、 Start Excel
２、図面から図形選択
３、属性など書出す情報の処理
４、 Excelファイルの保存
_________________________________________

動作条件として
ブロック名 "*_aTag" 属性文字があること
サンプル図面
_________________________________________

Sub Example_AttExcelOut()

' Start Excel
On Error Resume Next
  
Dim Excel As Object
Dim exBook As Workbook
Dim exSheet As Worksheet

Set Excel = GetObject(, "Excel.Application")
  
    If Err <> 0 Then
        Err.Clear
        Set Excel = CreateObject("Excel.Application")
          
        If Err <> 0 Then
            MsgBox "Could not load Excel.", vbExclamation
            End
        End If
    End If
  
    On Error GoTo 0
  
    Excel.Visible = True
  
    Set exBook = Excel.Workbooks.Add
    Set exSheet = exBook.Sheets("Sheet1")

'図形選択 /////////////////////////////////////////////////
    Dim SSet As AcadSelectionSet
    Dim GroupCode(1) As Integer
    Dim DataValue(1) As Variant
    Dim acBlObj As AcadBlockReference 'ブロック図形
On Error Resume Next
 If Not IsNull(ThisDrawing.SelectionSets.Item("SS1")) Then
    Set SSet = ThisDrawing.SelectionSets.Item("SS1")
    SSet.Delete
 End If
 
    Set SSet = ThisDrawing.SelectionSets.Add("SS1")
    '(2 . "*_aTag") ブロック名 , (0 . "INSERT") ブロック図形
    GroupCode(0) = 2
    DataValue(0) = "*_aTag"
    GroupCode(1) = 0
    DataValue(1) = "INSERT"
 
   SSet.Select acSelectionSetAll, , , GroupCode, DataValue
 
Dim ssCount As Integer
    ssCount = SSet.Count
  
    If ssCount = 0 Then
        MsgBox "書出すBlockがありません"
        Exit Sub 'プロシージャから抜ける
    End If
  
Dim attArray As Variant '属性のリスト
Dim blockHandle As String 'ブロック図形のハンドル番号
                          'Excelからアクセスする時に利用する番号
                          '（書出しのみであれば不要）
Dim rowNum As Integer
Dim colNum As Integer
    rowNum = 1 'Excel行番号
    colNum = 1 'Excel列番号

'選択したブロックの繰返し処理 +++++++++++++++++++++++++
For Each acBlObj In SSet
    If acBlObj.HasAttributes Then '属性を持っていたら
        attArray = acBlObj.GetAttributes '属性の取得
        blockHandle = acBlObj.Handle
      
        With exSheet.Cells(rowNum, colNum)
            .NumberFormatLocal = "@" '文字として書込み
            .Value = blockHandle
        End With
      
       For colNum = LBound(attArray) To UBound(attArray)
          exSheet.Cells(rowNum, colNum + 1).Value = attArray(colNum - 1).TextString
        Next
      
        rowNum = rowNum + 1
        colNum = 1
      
    End If '.HasAtt
Next
'++++++++++++++++++++++++++++++++++++++++++++++++++++++

'Excelファイルの保存
    Dim docName As String
    Dim acadFname As String
    Dim exFname As String
    Dim exSfname As String
  
    docName = ThisDrawing.FullName
        If docName = "" Then
            acadFname = ThisDrawing.Name
        Else
            acadFname = docName
        End If
  
    exFname = Left(acadFname, (Len(acadFname) - 4))

    Do ' wait until the user supplies a file name or cancels
        exSfname = Excel.GetSaveAsFilename(exFname, "Microsoft Excel Worksheet(*.xls), *.xls")
    Loop Until exSfname <> ""
  
    If exSfname <> "False" Then ' if they cancel, the file name is "False"
        exBook.SaveAs FileName:=exSfname
        'Error  1004-------------------------------------------------
        If Err.Number = 1004 Then
            Err.Clear
        End If
    End If
  
    Set exSheet = Nothing ' release memory
    Set exBook = Nothing
    Set Excel = Nothing

End Sub

C : VBA

●図形の選択3

選択Filterの適用

LISPを知っていればカンタンなことだが

知らないひとは

「コマンド：Filter」から条件をとりだす。

１、「選択フィルタ」のリストから

　　適用したい条件を選び、「リストに追加」

　　「適用」クリックし試してみる。

２、成功なら名前入力「名前を付けて保存」

３、エクスプローラで「filter.nfl」 ファイルを検索

　　メモ帳で開く

　　括弧”（ ）”の部分をコピー

(8 . "A-Anno-Note")
(0 . "*POLYLINE")

これをVBで配列に割当てる

    Dim GroupCode(0 to 1) As Integer
    Dim DataValue(0 to 1) As Variant
    GroupCode(0) = 8
    DataValue(0) =  "A-Anno-Note"
    GroupCode(1) = 0
    DataValue(1) =  "*POLYLINE"

____________________________________________

Sub Example_Select3()
'Filterの適用

    Dim SSet As AcadSelectionSet
    Dim GroupCode(4) As Integer
    Dim DataValue(4) As Variant
    Dim acadObj As AcadObject
   
 On Error Resume Next
 ' Delete the Selection Set if it Exists
 If Not IsNull(ThisDrawing.SelectionSets.Item("SS1")) Then
    Set SSet = ThisDrawing.SelectionSets.Item("SS1")
    SSet.Delete
 End If
   
    Set SSet = ThisDrawing.SelectionSets.Add("SS1")
    'Setup Selection Set Filter
'(-4 . "<OR")(0 . "LINE")(0 . "*POLYLINE")(0 . "CIRCLE")(-4 . "OR>")

    GroupCode(0) = -4
    DataValue(0) = "<OR"
    GroupCode(1) = 0
    DataValue(1) = "LINE"
    GroupCode(2) = 0
    DataValue(2) = "*POLYLINE"
    GroupCode(3) = 0
    DataValue(3) = "CIRCLE"
    GroupCode(4) = -4
    DataValue(4) = "OR>"
   
   SSet.SelectOnScreen GroupCode, DataValue
  
For Each acadObj In SSet
    Debug.Print acadObj.ObjectName
Next

End Sub

C : VBA

●図形の選択2

図形選択の方法２

対話しながらの選択
____________________________________________

１、シングル選択

GetEntity メソッド
GetSubEntity メソッド

２、SelectOnScreen メソッド
　　「オブジェクト選択：」を表示

３、Select メソッド
     Getxxxメソッドで予め点を取り組合わせ利用
　　モード
　　acSelectionSetWindow
　　acSelectionSetCrossing
　　acSelectionSetPrevious
　　acSelectionSetLast
　　acSelectionSetAll

　　SelectByPolygon メソッド
　　モード
　　acSelectionSetFence
　　acSelectionSetWindowPolygon
　　acSelectionSetCrossingPolygon 

　　SelectAtPoint メソッド
____________________________________________

Sub Example_Select2()

    Dim SSet As AcadSelectionSet '選択Set 選択図形をほうりこむ箱
                                 '"SS1"は箱の名前（なんでも良い）
    Dim acadObj As AcadObject
   
 On Error Resume Next  'Errorがあっても次に進む
 ' Eorror処理 もし同じ選択Setがあったら削除
 If Not IsNull(ThisDrawing.SelectionSets.Item("SS1")) Then
    Set SSet = ThisDrawing.SelectionSets.Item("SS1")
    SSet.Delete
 End If
   
    Set SSet = ThisDrawing.SelectionSets.Add("SS1")
    '選択Setを図面に追加
   
    SSet.SelectOnScreen
    '画面上で図形選択
  
For Each acadObj In SSet
    Debug.Print acadObj.ObjectName
Next

End Sub

C : VBA

●図形の選択1

図形選択の方法

図面全体（データベース）から
取得する方法と対話しながらの選択とがある。

モデル空間にある全ての図形にアクセスする
（データ量が多いと結構時間が掛かる）
__________________________________________

Sub Example_Select1()

Dim acMS As AcadModelSpace 'Model空間
Dim acadObj As AcadObject 'AutoCAD図形

Set acMS = ThisDrawing.ModelSpace
'ThisDrawing : 現在開いているアクティブなファイル

For Each acadObj In acMS

    'この中で色々な繰返し処理をさせる
    Debug.Print acadObj.ObjectName
   'イミディエイト・ウィンドウに表示される
Next

End Sub
__________________________________________

C : VBA

●ユーザー入力

「Utility」には
Getxxx なるメソッドが幾つかある。

「オブジェクト モデル 」から
Document-Utility（一番下）

メソッドの一覧からGetPoint メソッドをクリック
サンプル コードから
_____________________________________________________________
Dim returnPnt As Variant

' Return a point using a prompt
returnPnt = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
_____________________________________________________________
の部分をコピーし貼付け

同様にGetCorner メソッドサンプル コードから下記をコピー
_____________________________________________________________
returnPnt = ThisDrawing.Utility.GetCorner(basePnt, "Enter Other corner: ")
_____________________________________________________________

エディタに貼付け
下記に変更し試してみる。
-----------------------------------------------------
Sub Example_AddLine2()
' This example adds a line in model space
Dim returnPnt1 As Variant
Dim returnPnt2 As Variant

' Return a point using a prompt
returnPnt1 = ThisDrawing.Utility.GetPoint(, " 1点目を指定 : ")

returnPnt2 = ThisDrawing.Utility.GetCorner(returnPnt1, " 2点目を指定 : ")

Dim lineObj As AcadLine

' Create the line in model space
Set lineObj = ThisDrawing.ModelSpace.AddLine(returnPnt1, returnPnt2)

End Sub

C : VBA

●プロパティの変更

LINEのレイヤーを「A」に変更
注）レイヤーは予め作成しておきます

Set ......の次の行に追加
lineObj.Layer = "A"

ついでに ZoomAll を ZoomExtentsにも変更してみる

C : VBA

●ブレークポイントとローカルウィンドウ

コード ウィンドウの左のバーをクリックすると
ブレークポイントができる。
実行するとここで一時中断

中断中 ローカルウィンドウで変数の内容が確認できる。
「F8」でステップごとに進む！

C : VBA

●VBA エディタの設定

画面まわりと設定
３つのウィンドウの表示
ローカル、イミディエイト、ウォッチ
各内容は「Visual Basic ユーザー インターフェイス ヘルプ」を参照

ツールバー

「表示」－「ツールバー」
[編集] ツールバーを表示
コメントブロックなどのツールがある

オプション
「ツール」－「オプション」
「変数の宣言を強制する」にチェック
新規のコードに「Option Explicit」が自動で記入される。

Option Explicit：
宣言されていない変数名を使うと、コンパイル時にエラーが発生

C : VBA

●AutoCAD VBA はじめの一歩

まずは操作をしてみよう。
HelpのサンプルからVBAエディタにコピーし実行！

メニュー「ヘルプ」から
「開発者用ヘルプ」を開く（2006は「その他のリソース」）

「ActiveX/VBA リファレンス」

「オブジェクト モデル 」へと進む
（AutoCADの地図と考えよう。）

ここから作成したい図形などを探す
まずは「LINE」