メモ‎ > ‎

AutoCAD VBA


投稿を登録

VBAの自動実行（つづく）

2010/06/11 15:52 に mura が投稿   [ 2010/06/11 19:17 に更新しました ]

オンラインヘルプには、
「マクロに AcadStartup という名前を付けることにより、VBA のロード時にマクロが自動的に実行されるようにできます。 acad.dvb ファイル内にある AcadStartup という名前のマクロは、VBA のロード時に自動的に実行されます。 」
と、あるのに、AcadStartupが自動的に実行されるのは「acad.dvb」だけのようです。 まあ、ウイルス対策上その方が好ましいのかもしれないのですけど、面倒なときもあります。
そこで、dvbファイルを画面にドラッグした場合だけAcadStartupを自動実行するVBAを作成する事に。
これでVBAをドラッグすると、その中に定義したツールバーが自動的に作成されるというVBAの環境が整います。

最初にAcadStartupを自動実行するVBAを実行するため（鶏と卵の関係？） LISPを使うことにしました。
（基本的には）acad.lspは起動時　最初の１回だけ実行すれば十分です。
なお、acad.lspとACADStartup.dvbはacad.exeと同じフォルダに置きます。

'--- acad.lspの内容 ---
(defun S::STARTUP() 
     (command "_-vbarun" "./ACADStartup.dvb!ThisDrawing.ACADStartup") 
) 
こちらは、イベントをトラップしています。
サンプルの流用程度の簡単なプログラム。
ロードしたVBAに、AcadStartupがあれば実行してくれます。
'--- ACADStartup.dvb の内容 ---
Option Explicit
Public WithEvents ACADApp As AcadApplication
Option Compare Text

Sub ACADStartup()
    ' この手続きを最初に実行してください。
    ' Public変数(ACADApp)を初期化し AcadApplication イベントを発生させます
    ' ThisDocument オブジェクトからアプリケーション オブジェクトを取得します
    
    Dim AcadWasNotRunning As Boolean
    ' エラーのトラップを留保します。
    On Error Resume Next
    Set ACADApp = GetObject(, "AutoCAD.Application.16")
    If Err.Number <> 0 Then AcadWasNotRunning = True
    Err.Clear    ' エラーが発生した場合は Err オブジェクトをクリアします。
End Sub

Private Sub ACADApp_BeginFileDrop _
                 (ByVal FileName As String, Cancel As Boolean)
    ' このサンプルはアプリケーション レベルの BeginFileDrop イベントで割り込みます。
    ' このイベントは、図面ファイルが AutoCAD にドラッグされたときに引き起こされます。
    ' このイベントを引き起こすには、
    '     1) サンプルの初期化を必ずしてください。
    '        Public 変数(ACADApp という名前)をこのイベントにリンクしてください。
    '     2) AutoCAD にファイルをドラッグしてください。
    
    Dim FS As FileSystemObject
    Set FS = CreateObject("Scripting.FileSystemObject")
    
    If FileName Like "*.dvb" Then
        LoadDVB FileName
        Dim strModule As String
        strModule = FS.GetBaseName(FileName)
        
        On Error Resume Next        ' エラーのトラップを留保します。
        RunMacro strModule & ".ThisDrawing.ACADStartup"
        Err.Clear                   ' エラーが発生した場合は Err オブジェクトをクリアします。
    End If
End Sub

（2005年1月 7日）

「VBAの自動実行 Part1」につづく・・・。

| 添付ファイル: 20050107_acadstartup.zip acadvba.jpg

ポリラインの面積 選択セットに対応

2010/06/11 15:50 に mura が投稿   [ 2010/06/11 19:18 に更新しました ]

ポリラインの面積を調べる部分を 選択セットに対応させることに。
SelectOnScreenメソッドとフィルタを使うと、処理が一気に楽になります。
エラー処理が必要な気がするけど・・・。
使用した選択セットの削除を確実にする例外処理は、何が良いんだろう？

'------------------------
'ポリラインの面積を調べる(選択セット対応)
'------------------------
Public Sub AreasToText()
    Dim ssPline As AcadSelectionSet
    Dim FilterType(0) As Integer
    Dim FilterData(0) As Variant
    Set ssPline = ThisDrawing.SelectionSets.Add("SSP1")
    'フィルタを定義（閉じている必要があれば追加すること）
    FilterType(0) = 0
    FilterData(0) = "LWPOLYLINE"
    'FilterType(1) = 70
    'FilterData(1) = 1  '1 = 閉じたポリライン
    'ユーザがポリラインを選択
    ssPline.SelectOnScreen FilterType, FilterData
   
    Dim entPline As AcadLWPolyline
    Dim dblArea As Double
    Dim strCode As String
    Dim count As Integer
    '面積を合計
    For Each entPline In ssPline
        dblArea = dblArea + entPline.Area
        count = count + 1
    Next entPline
    '選択セットの処理
    ThisDrawing.SelectionSets.Item("SSP1").Delete
    '面積を表示する文字を作成
    If count > 0 Then
        strCode = Format(dblArea / 1000000, "##,##0.000 ㎡")
        'マルチテキストの作成位置を指定
        Dim basePnt As Variant
        Dim acMtext As AcadMText
        Dim width As Double
        'width = 1000
        basePnt = ThisDrawing.Utility.GetPoint(, "マルチテキストの左上コーナーを指定: ")
        Set acMtext = ThisDrawing.ModelSpace.AddMText(basePnt, width, strCode)
        acMtext.Update
    End If
End Sub

（2005年1月 5日）

VBAでコマンドとツールバーを追加するサンプル

2010/06/11 15:47 に mura が投稿   [ 2010/06/11 19:19 に更新しました ]

ポリラインの面積サンプルプログラムを使って、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日）

文字を処理するVBA

2010/06/11 15:38 に mura が投稿   [ 2010/06/11 19:19 に更新しました ]

必要だなと思いついたときに作ったものを、寄せ集めたものです。
従って、一貫性は無いのですが・・・。役に立つときがあるかも。
文字をくっつけたり、マルチテキストに変更します。
あとは文字の幅をスライダで変えます。
複数の文字が一度の伸び縮みする様は見ていて面白いです。

入っているコマンド一覧。
・複数の１行文字を 連結する
・複数の１行文字を 連結してマルチテキストに変換する
・位置あわせが フィット(F)になっている文字を 中心(C)に変更する
・文字の縦横比変更
※ボタンのイメージは入っていないので、適当に書き換えてください。

（2005年1月26日）

| 添付ファイル: Text_Lib.zip

フィールドコード VBAサンプル

2010/06/11 15:33 に mura が投稿

掲示板でフィールドコードで調べた面積を、mm2単位から100万分の1にしてm2にする方法をさがしていました。

以前、どっかでプログラムを組んだような気がして、やってみましたけどそのときは別の方法を使っていました。
というわけで、結論はやっぱり無理で・・・検証のための作りかけのVBAだけが残りました。
もったいないのでここに書いて、後から使い回ししよう。
'-------------------------------------------------------------
' -フィールドコード追加サンプルプログラム
' - http://www.mura.sh/
' - (c) mura. 2004  All rights reserved
'-------------------------------------------------------------

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
        MsgBox "Program ended." & Err, , "フィールドコード プログラム"
        Err.Clear
        Exit Sub
    Else
        If (returnObj.ObjectName = "AcDbPolyline") Then
            Set acPline = returnObj
            'フィールド式の定義
            strCode = "%<\AcObjProp Object(%<\_ObjId " & acPline.ObjectID & ">%).Area \f ""%.1f ÷1000000が面積"">%"
            '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

(2004年12月28日)

1-5 of 5