Egg's Blog

●Mechanicalの図面設定

Mechanical 2006 の初期設定について
（Mecha以外で作図した図面（主に旧図面）の初期設定の単位と規格の変更）

おまけツールの「Mechanical File Migration Utility」で複数図面の変換は可能！
（他にもレイヤー、ブロック、バルーンの更新も可！）
ただし、1枚々開いて閉じてを繰り返す、、、

必要なものだけ変換ということで、
規格と単位変更のみに挑戦してみた。

_______________________________________________
ActiveX（VBA）
参照設定にて「Autodesk SymBBAuto 2.0 type library」
(SymBBAuto.dll)にチェック

Sub mechaSet
Thisdrawing.SetVariable "MEASUREMENT" ,1

Dim symbb As McadSymbolBBMgr
Set symbb = ThisDrawing.Application.GetInterfaceObject("SymBBAuto.McadSymbolBBMgr")

Dim stdmgr As McadStandardMgr
Set stdmgr = symbb.StandardMgr
　　　stdmgr.CurrentStandardName = "JIS"
End Sub
_______________________________________________

LISP
(setvar "MEASUREMENT" 1)
(vl-load-com)
(setq symbb (vlax-get-or-create-object "SymBBAuto.McadSymbolBBMgr"))
(if (vlax-typeinfo-available-p symbb)
(progn
(setq stdmgr (vlax-get symbb 'StandardMgr))
(vlax-put stdmgr 'CurrentStandardName "JIS")

(vlax-release-object stdmgr)
(vlax-release-object symbb)
)
)

●VBAからVB .netへ

as さんの　「VB2005用ActiveXテンプレート」を利用させて戴いて
　
「Visual Basic 2005 Express Edition」でAutoCAD2006をカスタマイズ！
　
移行はとーってもカンタンだ

VBAで作成したコードをそのままコピー
「Thisdrawing」を「doc」に置き換え
（Dim doc As AcadDocument = Loader.AcadApp.ActiveDocument）

の部分を消すと

自動で選択群が出てきて 選ぶだけ

　
エディタは使いやすい。

サンプルは
ペーパー空間で浮動モデルの画面移動
レイアウトの位置合わせをする時に利用している。
（ビューはロックされる）
　
「サンプルdll」
（サポートパスが通っているフォルダへ配置）
コマンド：netload [AutoCAD 2006 ActiveX Test1.dll]を選択
コマンド「an_ppan」
　
「サンプルコード」
　
asさんに感謝！

「NetLoad」についてはmuraさんのこちらを参照

●コマンドラインでオプションの表示

Getpoint メソッドを利用して
座標 または　オプション文字を取得するには

InitializeUserInput メソッドで キーワードを作成
GetInput メソッドで入力された文字を取得します。

参考：AutoCADHelp　ActiveX/VBA 開発者用ガイド
「GetInput メソッド, GetInteger メソッドと使用」

'///////////////////////////////////////////////////////////////////////

Sub pointTest()

Dim pntA As Variant
Dim tempPnt(2) As Double
Dim initStr As String
Dim keyStr As String
Dim promptStr As String

    '点の定義
    tempPnt(0) = 10#: tempPnt(1) = 10#: tempPnt(2) = 10#

    'InitializeUserInputのキーワード
    keyStr = "U C"
   
    'コマンドプロンプト
    promptStr = "next point [元に戻す(U)/閉じる(C)]: "
   
    '点の取得
    pntA = anGetPnt(initStr, tempPnt, keyStr, promptStr)
   
    If IsEmpty(pntA) Then
        MsgBox initStr
    Else
        MsgBox pntA(0) & "," & pntA(1) & "," & pntA(2)
    End If
   
End Sub

'-----------------------------------------------------------

Function anGetPnt(ByRef gWord As String, beforPnt As Variant, keyWordStr As String, mesageStr As String) As Variant

On Error Resume Next

    'InitializeUserInput
    ThisDrawing.Utility.InitializeUserInput 2, keyWordStr
   
    '参照点の判別
    If IsEmpty(beforPnt) Then
    anGetPnt = ThisDrawing.Utility.GetPoint(, mesageStr)
    Else
    anGetPnt = ThisDrawing.Utility.GetPoint(beforPnt, mesageStr)
    End If
   
    If Err Then
        Select Case Err.Number
        Case -2147352567  'Esc
            gWord = "Esc"
           
        Case -2145320928  ' Put Keyboard
            '文字の取得
            gWord = ThisDrawing.Utility.GetInput
            If gWord = "" Then
                gWord = "Enter"
            End If
           
        Case Else
        End Select
        Err.Clear
    End If
End Function

●VBAをコマンド登録 & メニュー作成

作成したVBA（dvb）をコマンドとして実行できるように登録

マクロ内に
^c^c(vl-vbarun "dvbファイル名!マクロ名")
という方法がある

ここでは少々面倒だがあえて
メニューを作成しコマンドとして登録してみる。

１、VBAファイル（SampleProject.dvb）をフォルダに保存
（例、d:\acCustom）

２、AutoCADからパスを通しておく
ファイルを相対的に利用できるようにする為です。
「ツール」-「オプション」　「ファイル」タブ
「サポートファイルの検索パス」を選択
「追加」をクリック、「参照」をクリック フォルダを選択します。

３、メニューの作成
部分CUIファイルを作成：「accustom.cui」
ツールバー　：「MyTools」
名前　　　　　：「Sampleコマンド」
コマンド　　　：「csample」
アイコン　　　：「csample.BMP」として登録

「ツール」-「メニュー」-「インターフェイス」

注）コマンドを新規作成した時は「acad」メニューに作成されます。
この後、別のメニューにドラッグすると ２つのコマンドが作成されてしまいます。
「acad」メニューにできたコマンドは削除しておきましょう。

４、mnlファイルの作成
コマンドとして利用できるようにLispで登録
mnlはこのメニューがロードされた時に自動的に読込まれるファイル。

メモ帳で
mnlファイルを作成：「accustom.mnl」

dvbファイル

●ExcelからDWG検索

幾つかのDWGファイルを繰返し作業する時
リストを作成しておくと便利！

下記は、Microsoftのサンプルのからコピーしたものです。
（Excel2002移行）

Excel　VBAの参照設定に
「Microsoft Scripting Runtime」を追加

Excel VBAへここから貼付け
____________________________________
Option Explicit
Option Compare Text

Function GetFiles(strPath As String, dctDict As Scripting.Dictionary, Optional blnRecursive As Boolean) As Boolean

' このプロシージャは、ディレクトリ内のすべてのファイルを
' Dictionary オブジェクトに返します。再帰的に呼び出
' される場合は、サブフォルダ内のファイルもすべて返します。

Dim fsoSysObj As Scripting.FileSystemObject
Dim fdrFolder As Scripting.Folder
Dim fdrSubFolder As Scripting.Folder
Dim filFile As Scripting.File

' 新しい FileSystemObject を返します。
Set fsoSysObj = New Scripting.FileSystemObject

On Error Resume Next
' フォルダを取得します。
Set fdrFolder = fsoSysObj.GetFolder(strPath)
If Err <> 0 Then
' パスが間違っています。
GetFiles = False
GoTo GetFiles_End
End If
On Error GoTo 0
'**************************************************************************
Dim sDwg
sDwg = ".dwg"
Dim rightName

On Error Resume Next
' Files コレクションをループし、Dictionary に追加します。
For Each filFile In fdrFolder.Files

rightName = Right(filFile, 4)
If rightName = ".dwg" Then
dctDict.Add filFile.Path, filFile.Path
'dctDict.Add filFile.Name, filFile.Name

End If
Next filFile
'**************************************************************************
' 再帰フラグが真の場合、再帰的に呼び出します。
If blnRecursive Then
For Each fdrSubFolder In fdrFolder.SubFolders
GetFiles fdrSubFolder.Path, dctDict, True
Next fdrSubFolder
End If

' エラーが発生しなかった場合は、True を返します。
GetFiles = True

GetFiles_End:
Exit Function
End Function
' __________________________________________________________________________________
Sub DWGファイル検索()

On Error Resume Next

Dim fs, f, s
Set fs = CreateObject("Scripting.FileSystemObject")

Dim dctDict As Scripting.Dictionary
Dim varItem As Variant
Dim strDirPath As String

Dim dwgFile As String 'ファイル名
Dim pathDwg As String '検索フォルダの場所
Dim i As Integer 'カウント
' ファイル ダイアログを開きます。
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = True
.Show

Dim foName As String
foName = .SelectedItems(1)

End With

'******************************************

strDirPath = foName & "\"
' 新規 Dictionary を作成します。
Set dctDict = New Scripting.Dictionary
' 再帰的に呼び出し、Dictionary オブジェクトにファイルを返します。
If GetFiles(strDirPath, dctDict, True) Then
' Dictionary 内の項目を出力します。

Dim enCount
i = 2

For Each varItem In dctDict

Cells(i, 1).Value = varItem

Set f = fs.GetFile(varItem)

enCount = InStrRev(varItem, "\") + 1

Cells(i, 2).Value = Mid(varItem, enCount)
Cells(i, 3).Value = f.DateLastModified

i = i + 1
Next

Cells(1, 1).Value = strDirPath
Cells(1, 1).Font.Bold = True
Cells(1, 2).Value = dctDict.Count & " Files"
Cells(1, 2).Font.Bold = True

Columns("A:C").EntireColumn.AutoFit
Cells(1, 2).Select
End If

End Sub
__________________________________________________________________________________

●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

●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

●図形の選択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

●図形の選択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

●図形の選択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
__________________________________________

●ユーザー入力

「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

●プロパティの変更

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

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

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

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

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

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

●VBA エディタの設定

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

ツールバー

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

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

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

●AutoCAD VBA はじめの一歩

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

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

「ActiveX/VBA リファレンス」

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

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