ポリラインの面積サンプルプログラムを使って、LispでVBAのコマンドを追加するサンプルとツールバーを追加、削除するコードを書いておきます。
ＶＢＡコマンドの追加には、「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日）
