 ＶＢＡコマンドの追加には、「Sub AddAcCommand」を使い ポイントはLISPのコマンドからVBAを呼び出すところ。 「(defun C:mura_[AutoCADコマンド名]() (command "-vbarun" "[プロジェクト名].ThisDrawing.[VBAサブプロージャ名]")(princ))」 ツールバーの追加・削除は 「Sub DeleteVBAToolBar()」と「Function AddAcToolBar」「Sub CreateVBAToolBar」あたり。 どちらも基本なので難しくない？ 面積を調べたり、文字を計算するのは割とよく使いたい機能なので、足し算と引き算。文字を選択セットで処理できると嬉しいかな・・・。 グリッドで処理できるともっと良いけど。 テキストボックスに一括して取り出すというのも簡単で使えるプログラムかも。 この周辺は、プログラムの精度を上げていくと可能性の広がる分野かな。 '------------------------------------------------------------- ' -ポリラインの面積サンプルプログラム ' - http://www.mura.sh/ ' - (c) mura. 2004 All rights reserved '------------------------------------------------------------- Const VBAMenuGroupName As String = "CUSTOM" Const VBAToolBarName As String = "Plineから面積の注釈を作成" Const ProjectName As String = "Pline2Area.ThisDrawing" Public Sub AddField() Dim returnObj As AcadObject Dim basePnt As Variant Dim acPline As AcadLWPolyline Dim acMtext As AcadMText Dim strCode As String Dim width As Double RETRY: On Error Resume Next '面積を調べるポリラインを選択 ThisDrawing.Utility.GetEntity returnObj, basePnt, vbCr + "ポリラインを選択: " If Err <> 0 Then Debug.Print "Program ended. Err:" & Err 'MsgBox "Program ended." & Err, , "VBA プログラム" Err.Clear Exit Sub Else If (returnObj.ObjectName = "AcDbPolyline") Then Set acPline = returnObj '計算 strCode = Format(acPline.Area / 1000000, "##,##0.000 ㎡") 'width = 1000 'マルチテキストの作成位置を指定 basePnt = ThisDrawing.Utility.GetPoint(, "マルチテキストの左上コーナーを指定: ") Set textObj = ThisDrawing.ModelSpace.AddMText(basePnt, width, strCode) acMtext.Update Exit Sub End If End If GoTo RETRY End Sub Public Sub CalcText() Dim returnObj As AcadObject Dim basePnt As Variant Dim acPline As AcadLWPolyline Dim acMtext As AcadMText Dim textObj As AcadMText Dim strCode As String Dim dubCode As Double Dim width As Double RETRY: On Error Resume Next '計算する文字を選択 ThisDrawing.Utility.GetEntity returnObj, basePnt, vbCr + "文字を選択: " If Err <> 0 Then 'MsgBox "合計: " & dubCode, , "VBA プログラム" Err.Clear GoTo MTXT 'Exit Sub Else If (returnObj.ObjectName = "AcDbMText") Then Set acMtext = returnObj 'フィールド式の定義 strCode = Left(acMtext.TextString, Len(acMtext.TextString) - 2) dubCode = dubCode + strCode End If End If GoTo RETRY MTXT: 'マルチテキストの作成位置を指定 basePnt = ThisDrawing.Utility.GetPoint(, "マルチテキストの左上コーナーを指定: ") Set textObj = ThisDrawing.ModelSpace.AddMText(basePnt, width, dubCode & " ㎡") textObj.Update Exit Sub End Sub '------------------------------------------- ' ツールバーの追加/定義 '------------------------------------------- Private Function AddAcToolBar(strGroupName, strTBarName As String) As AcadToolbar Dim objToolBars As AcadToolbars Dim objToolBar As AcadToolbar Set objToolBars = ThisDrawing.Application.MenuGroups.Item(VBAMenuGroupName).Toolbars On Error Resume Next Set AddAcToolBar = objToolBars.Add(strTBarName) If Err Then Set AddAcToolBar = objToolBars.Item(strTBarName) ' MsgBox "'VBA ToolBar' already exists!!" Exit Function End If On Error GoTo 0 'AddAcToolBar = objToolBar End Function '------------------------------------------- ' ボタンの追加/定義 '------------------------------------------- Private Sub AddAcButton(objToolBar As AcadToolbar, _ vrIndex As Variant, _ stName, stHelpString, strCommand, srtSub, SmallIconName, LargeIconName As String) Dim objToolbarItem As AcadToolbarItem 'VBAコマンドの定義 Call AddAcCommand(strCommand, srtSub) 'strCommand:AutoCADのコマンド名 strVbaSub:VBAサブプロージャ名 'ツールバーボタンの作成strVbaSub Set objToolbarItem = objToolBar.AddToolbarButton(vrIndex, stName, stHelpString, ".." & strCommand & vbCr) Call objToolbarItem.SetBitmaps(SmallIconName, LargeIconName) End Sub '------------------------------------------- ' ＶＢＡコマンドの追加/定義 '------------------------------------------- Private Sub AddAcCommand(strCommand, strVbaSub As Variant) 'strCommand:AutoCADのコマンド名 strVbaSub:VBAサブプロージャ名 Dim ExecCmd As String ExecCmd = Chr(34) & "-vbarun" & Chr(34) & " " & Chr(34) & ProjectName & "." & strVbaSub & Chr(34) ThisDrawing.SendCommand "(defun C:" & strCommand & "() (command " & ExecCmd & ")(princ))" & vbCr End Sub '------------------------------------------------------------------------- 'ツールバーの削除 '------------------------------------------------------------------------- Sub DeleteVBAToolBar() Dim objToolBars As AcadToolbars Dim objToolBar As AcadToolbar Set objToolBars = ThisDrawing.Application.MenuGroups.Item(VBAMenuGroupName).Toolbars For Each objToolBar In objToolBars ' コレクションの各要素に対して繰り返します。 If objToolBar.Name = VBAToolBarName Then ' Text プロパティが "Hello" であれば、 objToolBar.Delete ' Found に True を設定します。 Exit For ' For ループから抜け出します。 End If Next End Sub '------------------------------------------------------------------------- 'ツールバーの作成 '------------------------------------------------------------------------- Sub CreateVBAToolBar() Dim objToolBar As AcadToolbar Set objToolBar = AddAcToolBar(VBAMenuGroupName, VBAToolBarName) Call AddAcButton(objToolBar, 0, "ツールバー削除", "VBAで作成したこのツールバーを削除", "mura_DeleteVBAToolBar", "DeleteVBAToolBar", "RCDATA_16_HLNK_STOP", "RCDATA_16_HLNK_STOP") Call AddAcButton(objToolBar, 0, "ポリラインの面積", "", "mura_af", "AddField", "RCDATA_16_AREA", "RCDATA_16_AREA") Call AddAcButton(objToolBar, 0, "面積の足し算", "", "mura_ct", "CalcText", "RCDATA_16_MTEXT", "RCDATA_16_MTEXT") End Sub （2005年1月 5日） |
メモ > AutoCAD VBA >