Issue バルーン番号の番号部分を属性定義（タグ名 Index）したブロック定義（ブロック名 MyBlock）があります。     このブロック定義の挿入時にバルーン番号を加算しながら重複のないバルーン番号を持つブロック参照を配置することは可能でしょうか？   Solution 新たな MyBlock ブロック参照の挿入時に、モデル空間に配置されたすべての MyBlock を走査して Index タグ名を持つ属性値（文字列）を取得、最大値となり値をバルーン番号に設定することで実現することが出来るはずです。   次のサンプルは、MyBlock ブロック定義後に同処理を実装する VBA マクロの例です。属性値の妥当性チェックの処理はしていませんが、インデックス番号を保持するタグ名 Index を持つ属性には、半角整数の文字列が設定されているものとしています。IndexOnBlockRef プロシージャを実行してみてください。   ' 挿入時に属性値（インデックス番号）を順番に割り当てるメイン プロシージャ Public Sub IndexOnBlockRef() Dim strBlkName strBlkName = "MyBlock" CreateBlockDef (strBlkName) Dim insPt(0 To 2) As Double insPt(0) = 0: insPt(1) = 0: insPt(2) = 0 Dim retPt As Variant Dim index As Integer Dim blockRefObj As AcadBlockReference On Error Resume Next Do Err.Clear retPt = ThisDrawing.Utility.GetPoint(, vbCrLf & "ブロックの挿入点を指示 : ") If Err Then Exit Do End If Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(retPt, strBlkName, 1#, 1#, 1#, 0) index = FindMaxIndexAttribute() Call SetIndexAttribute(blockRefObj, index + 1) Loop End Sub ' 属性定義（タグ名 Index）を含むブロック定義 MyBlock を定義する関数 Public Function CreateBlockDef(strBlkName As String) Dim blockObj As AcadBlock Dim insPt(0 To 2) As Double insPt(0) = 0: insPt(1) = 0: insPt(2) = 0 On Error Resume Next Set blockObj = ThisDrawing.Blocks.Item(strBlkName) If Err Then Set blockObj = ThisDrawing.Blocks.Add(insPt, strBlkName) Dim circleObj As AcadCircle Set circleObj = blockObj.AddCircle(insPt, 100#) Dim attributeObj As AcadAttribute Set attributeObj = blockObj.AddAttribute(100#, acAttributeModePreset, "インデックス？", insPt, "Index", "0") attributeObj.Alignment = acAlignmentMiddleCenter End If End Function ' 与えられたブロック参照のタグ名 Index の属性値（整数）を返す関数 Public Function GetIndexAttribute(blockRefObj) As Integer Dim varAttributes As Variant varAttributes = blockRefObj.GetAttributes Dim strAttribute As String strAttribute = "-1" For Each blockAttr In varAttributes If blockAttr.TagString = "Index" Then strAttribute = blockAttr.TextString Exit For End If Next GetIndexAttribute = CInt(strAttribute) End Function ' モデル空間に配置されたすべての MyBlock ブロック参照を走査して割り当てられた最大の Index の属性値（整数）を返す関数う Public Function FindMaxIndexAttribute() As Integer Dim sset As AcadSelectionSet On Error Resume Next Set sset = ThisDrawing.SelectionSets.Item("ssblocks") If Not Err Then sset.Delete End If Set sset = ThisDrawing.SelectionSets.Add("ssblocks") Dim FilterType(1) As Integer Dim FilterData(1) As Variant FilterType(0) = 0 FilterData(0) = "Insert" FilterType(1) = 2 FilterData(1) = "MyBlock" sset.Select acSelectionSetAll, , , FilterType, FilterData Dim index As Integer index = -1 Dim maxIndex As Integer maxIndex = -1 If sset.Count > 0 Then Dim entityObj As AcadEntity For Each entityObj In sset Dim blockRefObj As AcadBlockReference Set blockRefObj = entityObj index = GetIndexAttribute(blockRefObj) If maxIndex < index Then maxIndex = index End If Next End If FindMaxIndexAttribute = maxIndex End Function ' 与えられたブロック参照1のタグ名 Index の属性値（整数）を設定する関数 Public Function SetIndexAttribute(blockRefObj, index) Dim varAttributes As Variant varAttributes = blockRefObj.GetAttributes For Each blockAttr In varAttributes If blockAttr.TagString = "Index" Then blockAttr.TextString = CStr(index) Exit For End If Next End Function     既に挿入配置済のブロック参照 My Block に新たにインデクス番号の属性値を割り当てる場合には、前述のコードに次の AssignIndexToBlockRef プロシージャを追加・実行することでブロック参照を順に選択して値を更新することも出来ます。   ' 配置済のブロック参照に指定値から属性値（インデックス番号）を順番に割り当てるメイン プロシージャ Public Sub AssignIndexToBlockRef() Dim strBlkName strBlkName = "MyBlock" Dim startIndex As Integer startIndex = FindMaxIndexAttribute() On Error Resume Next Err.Clear Dim returnInt As Integer ThisDrawing.Utility.InitializeUserInput (4) ' disallow negative returnInt = ThisDrawing.Utility.GetInteger(vbCrLf & "割り当てるインデクス開始値を入力<" & CStr(startIndex + 1) & "> : ") If Err = 0 Then If returnInt <= startIndex Then MsgBox ("指定した値と同じ、または、大きいインデックス値を持つブロック参照が既に存在します" & vbCrLf & _ "既に配置済のブロック参照とインデックス値が重複してしまう可能性があります") Exit Sub End If startIndex = returnInt - 1 End If Dim returnObj As AcadObject Dim basePnt As Variant Do Err.Clear ThisDrawing.Utility.GetEntity returnObj, basePnt, "ブロック参照を選択:" If Err = 0 Then If returnObj.EntityName = "AcDbBlockReference" Then Dim blockRefObj As AcadBlockReference Set blockRefObj = returnObj If blockRefObj.Name = strBlkName Then startIndex = startIndex + 1 Call SetIndexAttribute(blockRefObj, startIndex) End If End If Else Exit Do End If Loop End Sub    

Issue VBA では表を TABLE オブジェクトで作成することが出来ますが、データ値にオブジェクトのプロパティをフィールドとして利用、表の内容を最新に保つようなことは出来ますか？   Solution  TABLE オブジェクト のデータセルにフィールド文字を挿入することは可能です。どのようなフィールド文字列を値に設定するべきかは、FIELD[フィールド] コマンド 表示される [フィールド] ダイアログで、特定のオブジェクトと同オブジェクト タイプで利用可能なプロパティを選択すると、ダイアログ下部の「フィールド式」に表示される内容で取得することが出来ます。   このとき、特定のオブジェクトは AutoCAD API の識別子の １つである ObjectId で関連付けされますので、VBA マクロでフィールド式をセルに指定する際に、適宜変更する必要があります。     次のマクロは、モデル空間に作図されているすべてのオブジェクトのハンドル番号とオブジェクト タイプ、オブジェクトの色を表に書き込むものです。色の情報がフィールド式で指定されているので、作図後に REGEN[再作図] コマンド を実行すると、値が更新されるようになります。   Option Explicit Public Sub FieldTable() ' 新しい表スタイルの作成 On Error Resume Next Dim oTblDict As AcadDictionary Set oTblDict = ThisDrawing.Dictionaries.Item("ACAD_TABLESTYLE") Dim oTblStyle As AcadTableStyle Set oTblStyle = oTblDict.Item("MyTableStyle") If Err Then ' 新しい表スタイル "MyTableStyle" を作成 Err.Clear Set oTblStyle = oTblDict.AddObject("MyTableStyle", "AcDbTableStyle") ' タイトル欄の設定（背景色：青、文字色：白、文字高さ：4.0） Dim oColor As AcadAcCmColor Set oColor = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.25") oColor.ColorIndex = acWhite oTblStyle.SetColor acTitleRow, oColor oColor.ColorIndex = acBlue oTblStyle.SetBackgroundColorNone acTitleRow, False oTblStyle.SetBackgroundColor acTitleRow, oColor oTblStyle.SetTextHeight acTitleRow, 4# oTblStyle.TitleSuppressed = False ' 列見出し欄の色設定（背景色：白、文字色：緑、文字高さ：2.5） oColor.ColorIndex = acWhite oTblStyle.SetColor acHeaderRow, oColor oColor.ColorIndex = acGreen oTblStyle.SetBackgroundColorNone acHeaderRow, True oTblStyle.SetBackgroundColor acHeaderRow, oColor oTblStyle.SetTextHeight acHeaderRow, 2.5 oTblStyle.HeaderSuppressed = False ' データ欄の色設定（背景色：なし、文字色：白、文字高さ：2） oColor.ColorIndex = acWhite oTblStyle.SetColor acDataRow, oColor oTblStyle.SetBackgroundColorNone acDataRow, True oTblStyle.SetTextHeight acDataRow, 2 oTblStyle.SetAlignment acDataRow, acMiddleCenter End If ' 配置基点を指示 Dim ptBase As Variant ThisDrawing.Utility.InitializeUserInput 1 ptBase = ThisDrawing.Utility.GetPoint(, vbCrLf & "表の配置点を指定:") ' 表特性の算出 Dim nRow As Integer Dim nCol As Integer Dim dHeight As Double nRow = ThisDrawing.ModelSpace.Count + 2 ' タイトル＋列見出し nCol = 3 dHeight = ThisDrawing.GetVariable("TEXTSIZE") ' 現在のレイアウトに表を配置 Dim oTbl As IAcadTable Set oTbl = ThisDrawing.ActiveLayout.Block.AddTable(ptBase, nRow, nCol, dHeight, dHeight * 10#) oTbl.RegenerateTableSuppressed = True oTbl.StyleName = "MyTableStyle" oTbl.GenerateLayout ' タイトルの設定 oTbl.SetText 0, 0, "モデル空間図形の色一覧" oTbl.SetRowHeight 0, 7# oTbl.SetText 1, 0, "ハンドル番号" oTbl.SetText 1, 1, "クラス名" oTbl.SetText 1, 2, "色" oTbl.SetRowHeight 1, 5# ' データの設定 Dim nRowCnt As Integer Dim strField As String Dim oEnt As AcadEntity nRowCnt = 2 For Each oEnt In ThisDrawing.ModelSpace ' ハンドル番号 oTbl.SetText nRowCnt, 0, oEnt.Handle ' クラス名 oTbl.SetText nRowCnt, 1, oEnt.ObjectName ' フィールド式（オブジェクトID で特定したオブジェクトの色） strField = "%<\AcObjProp Object(%<\_ObjId " & CStr(oEnt.ObjectID) & ">%).TrueColor>%" oTbl.SetText nRowCnt, 2, strField ' 行高さの設定 oTbl.SetRowHeight nRowCnt, 5# ' 行カウンタ nRowCnt = nRowCnt + 1 Next oTbl.RegenerateTableSuppressed = False End Sub   このマクロコードでは、表スタイルを登録して表に使用しています。表スタイルの内容と図面の尺度が適切でない場合がありますので、必要に応じて文字高さ等を変更してください。AutoCAD VBA では、表スタイルは TableStyle オブジェクト で作成・編集することが出来ます。この例では、椅子のブロック参照の色を水色（cyan）から青（blue）に変更しています。    

Issue VBA マクロで特定のブロック名パターンを持つブロックのブロック属性を得たいのですが、可能でしょうか？ 例えば、図面内の A で始まるブロック名を持つすべてのブロックのみを対象にする、といった方法です。   Solution 特定のブロック名パターンに検索には、選択セットのフィルタ リストにアスタリスク記号でワイルドカード（*）を組み合わせて指定することが出来ます。A で始まるブロック名を持つブロックは、A* で指定可能です。   次のコードは、ワイルドカードを含めたブロック名パターンを指定して、対象ブロック参照を取得、ブロック属性の有無をチェックして、ブロック属性が含まれる場合に属性のタグと値を表示するものです。なお、*fix* や *tub など、ワイルドカードはブロック名中、どこに置いても指定することが出来ます。   Public Sub GetBlockAttribute2() On Error Resume Next Dim sset As AcadSelectionSet ThisDrawing.SelectionSets.Item("ssblocks").Delete Set sset = ThisDrawing.SelectionSets.Add("ssblocks") ThisDrawing.Utility.InitializeUserInput NoNull returnString = ThisDrawing.Utility.GetString(True, "対象のブロック名を入力 [すべて (*) ] : ") If returnString = "" Then returnString = "*" End If Dim FilterType(1) As Integer Dim FilterData(1) As Variant FilterType(0) = 0 FilterData(0) = "Insert" FilterType(1) = 2 FilterData(1) = returnString sset.Select acSelectionSetAll, , , FilterType, FilterData If sset.Count > 0 Then Dim ent As AcadEntity For Each ent In sset Dim blkRef As AcadBlockReference Set blkRef = ent ThisDrawing.Utility.Prompt vbCrLf & blkRef.Name & " ブロック参照が検出されました." Dim varAttributes As Variant varAttributes = blkRef.GetAttributes If UBound(varAttributes) < 0 Then ThisDrawing.Utility.Prompt vbCrLf & " ブロック参照に属性がありません..." Else Dim strAttributes As String For Each blkAttr In varAttributes strAttributes = "" strAttributes = strAttributes & " タグ名: " & blkAttr.TagString & " - 属性値 " & blkAttr.TextString & vbLf & " " ThisDrawing.Utility.Prompt vbCrLf & strAttributes Next End If Next Else ThisDrawing.Utility.Prompt vbCrLf & returnString & " ブロック名パターンに合致するブロック参照がありません..." End If End Sub   次の例では、ブロック名パターン * で全ブロックのブロック属性を、A* で A で始まるブロック名を持つブロック参照のブロック属性を表示しています。  

Issue VBA コードでブロック参照に設定されているブロック属性を取得する手順を教えてください。   Solution 挿入されているブロック参照は AcadBlockReference オブジェクト として取得することが出来ます。   AcadBlockReference オブジェクト には属性を取得する GetAttributes メソッド が用意されているので、このメソッドを介して各属性の情報を取得することが出来ます。   なお、ブロック参照の定義情報であるブロック定義（Block オブジェクト）には複数の属性定義（Attribute オブジェクト）を登録出来るので、 GetAttributes メソッドが複数が属性（AttributeReference オブジェクト）を扱えるよう、配列を返すことにご注意ください。   次の例は、選択したブロック参照から属性のタグと値を表示するコードです。VBA コード上、 GetAttributes メソッドが返すのが Variant 型になっています。   Public Sub GetBlockAttribute() Dim returnObj As AcadObject Dim basePnt As Variant On Error Resume Next ThisDrawing.Utility.GetEntity returnObj, basePnt, "ブロック参照を選択:" If Err = 0 Then If returnObj.EntityName = "AcDbBlockReference" Then Dim blkRef As AcadBlockReference Set blkRef = returnObj ThisDrawing.Utility.Prompt vbCrLf & blkRef.Name & " ブロック参照が選択されました." Dim varAttributes As Variant varAttributes = blkRef.GetAttributes If UBound(varAttributes) < 0 Then ThisDrawing.Utility.Prompt vbCrLf & "ブロック参照に属性がありません..." Else Dim strAttributes As String For Each blkAttr In varAttributes strAttributes = "" strAttributes = strAttributes & " タグ名: " & blkAttr.TagString & " - 属性値 " & blkAttr.TextString & vbLf & " " ThisDrawing.Utility.Prompt vbCrLf & strAttributes Next End If ElseIf returnObj.EntityName <> " AcDbBlockReference" Then ThisDrawing.Utility.Prompt vbCrLf & "ブロック参照ではありません..." End If Else ThisDrawing.Utility.Prompt vbCrLf & "何も選択されませんでした..." End If End Sub    

Issue VBA で拡張エンティティ データを付加・参照・削除するには、それぞれ、どのようなマクロを作成すればいいでしょうか？   Solution 拡張エンティティ データは、AutoCAD 図面内の任意のオブジェクトに任意のカスタム データの付加、参照する手法です。   AutoCAD の標準コマンドは、付加された拡張エンティティ データを認識しないので、標準ユーザー インタフェースに値が表示されることはありませんが、逆に、ユーザから付加された固有データを隠蔽することが可能です。また、プログラムを介在させない限り、拡張エンティティ データを削除したり、値を変更したりすることができないので、ユーザーによる改変を防止することもできます。    次のコードは、拡張エンティティ データを付加する SetXData マクロ、参照する GetXData マクロ、削除する RemoveXData マクロの例です。 Public Sub GetXData() 'オブジェクト選択 Dim ptPick As Variant Dim oEnt As Object Dim oUtil As AcadUtility Set oUtil = ThisDrawing.Utility oUtil.GetEntity oEnt, ptPick, "拡張オブジェクトデータを参照する図形を選択:" '拡張オブジェクトデータ取得 Dim vXDataType As Variant Dim vXDataValue As Variant oEnt.GetXData "MYDATA", vXDataType, vXDataValue If VarType(vXDataType) = vbEmpty Then oUtil.Prompt (vbCrLf & "拡張オブジェクトデータ 'MYDATA' が付加されていません...") Else 'データ表示 oUtil.Prompt (vbCrLf & "年齢は " & CInt(vXDataValue(2))) oUtil.Prompt (vbCrLf & "身長は " & CDbl(vXDataValue(3))) oUtil.Prompt (vbCrLf & "体重は " & CDbl(vXDataValue(4))) oUtil.Prompt (vbCrLf & "人相は " & CStr(vXDataValue(5))) End If End Sub Public Sub SetXData() 'オブジェクト選択 Dim ptPick As Variant Dim oEnt As Object Dim oUtil As AcadUtility Set oUtil = ThisDrawing.Utility oUtil.GetEntity oEnt, ptPick, "拡張オブジェクトデータを付加する図形を選択:" '拡張オブジェクトデータ取得 Dim vXDataType As Variant Dim vXDataValue As Variant oEnt.GetXData "MYDATA", vXDataType, vXDataValue If VarType(vXDataType) <> vbEmpty Then oUtil.Prompt (vbCrLf & "既に拡張オブジェクトデータ 'MYDATA' が付加されています...") Else '入力 Dim nAge As Integer oUtil.InitializeUserInput (7) nAge = oUtil.GetInteger(vbCrLf & "年齢を入力(整数):") Dim dHeight As Double oUtil.InitializeUserInput (7) dHeight = oUtil.GetReal(vbCrLf & "身長を入力(実数):") Dim dWeight As Double oUtil.InitializeUserInput (7) dWeight = oUtil.GetReal(vbCrLf & "体重を入力(実数):") Dim strLooks As String strLooks = oUtil.GetString(True, vbCrLf & "人相を入力(文字):") 'データ付加 Dim nDataType(0 To 6) As Integer Dim vDataValue(0 To 6) As Variant nDataType(0) = 1001 'アプリケーション名 vDataValue(0) = "MYDATA" 'アプリケーション名 nDataType(1) = 1002 'コントロール文字 vDataValue(1) = "{" 'コントロール文字 nDataType(2) = 1070 '年齢（整数） vDataValue(2) = nAge '年齢（整数） nDataType(3) = 1040 '身長（実数） vDataValue(3) = dHeight '身長（実数） nDataType(4) = 1040 '体重（実数） vDataValue(4) = dWeight '体重（実数） nDataType(5) = 1000 '人相（文字） vDataValue(5) = strLooks '人相（文字） nDataType(6) = 1002 'コントロール文字 vDataValue(6) = "}" 'コントロール文字 oEnt.SetXData nDataType, vDataValue End If End Sub Public Sub RemoveXData() 'オブジェクト選択 Dim ptPick As Variant Dim oEnt As Object Dim oUtil As AcadUtility Set oUtil = ThisDrawing.Utility oUtil.GetEntity oEnt, ptPick, "拡張オブジェクトデータを削除する図形を選択:" '拡張オブジェクトデータ取得 Dim vXDataType As Variant Dim vXDataValue As Variant oEnt.GetXData "MYDATA", vXDataType, vXDataValue If VarType(vXDataType) <> vbEmpty Then 'データ付加 Dim nDataType(0) As Integer Dim vDataValue(0) As Variant nDataType(0) = 1001 'アプリケーション名 vDataValue(0) = "MYDATA" 'アプリケーション名 oEnt.SetXData nDataType, vDataValue Else oUtil.Prompt (vbCrLf & "拡張オブジェクトデータ 'MYDATA' が付加されていません...") End If End Sub 1 オブジェクトへの付加サイズ総量が 16 キロバイトまでに制限されています。 削除したい拡張エンティティ データのアプリケーション名を SetXData メソッドで上書きすると、同じアプリケーション名の拡張エンティティ データを削除することが出来ます。 付加されている拡張エンティティ データは、Express Tools の XDLIST コマンドで参照することが出来ます。

Issue 現在オープンしている図面の図形を別の図面にコピーしたいのですが、コピー元の図形が参照している画層や線種を一緒にコピーすることは出来ますか？   もし、可能なら、寸法をコピーする際に参照している寸法スタイルを、テキスト文字をコピーする際に参照している文字スタイルを同時にコピー出来ると便利です。   Solution AutoCAD には、オブジェクトの参照関係（つながり）を維持したままコピーをおこなう ディープクローン という機構が存在しています。   ディープクローンを使用すると、図形そのもののコピーだけでなく、そのオブジェクトが参照している他のオブジェクトも深く（ディープ）参照して、元の状態を維持したまま対象図形を別の図面にコピーすることが可能です。例えば、図面 A の線分が同じ図面の ”通り芯” 画層している場合、その線分を図面 B にディープクローンすると、”通り芯” 画層も一緒に、そして、自動的にコピーしてくれます。寸法スタイルや文字スタイルも同様にコピーされます。   VBA が利用する ActiveX オートメーションでは、CopyObjects メソッド でディープクローンを利用することが出来ます。    次の VBA マクロはタイル状に並べた左側の図面のモデル空間の図形を、右側の図面にディープクローンするものです。VBA マクロ実行前、右側の図面には図形や画層はありませんが、図形のディープクローン時に画層もコピーされていることがわかります。   Public Sub DeepClone() Dim A As AcadDocument Set A = ThisDrawing.Application.ActiveDocument Dim B As AcadDocument Set B = ThisDrawing.Application.Documents.Item(1) ThisDrawing.Application.ActiveDocument = A Dim entity As AcadEntity Dim retObjects As Variant Dim index As Integer Dim length As Integer ReDim objCollection(0 To A.ModelSpace.Count - 1) As Object index = 0 For Each entity In A.ModelSpace ThisDrawing.Utility.Prompt (vbCrLf & entity.ObjectName) Set objCollection(index) = entity index = index + 1 Next retObjects = A.Database.CopyObjects(objCollection, B.ModelSpace) ThisDrawing.Application.ActiveDocument = B For index = 0 To length retObjects(index).Update Next B.Application.ZoomExtents End Sub  AutoCAD ActiveX オートメーションでは、ディープクローン先に参照している画層やスタイルがあると、画層やスタイルのディープクローンはおこなわれません（上書きはしません）。 

Issue 現在オープンしている図面に配置されている "TEST" ブロック参照を、別の図面に定義されている同じ名前のブロック定義を元に置き換えたいのですが、AutoCAD VBA で可能でしょうか？    Solution AutoCAD VBA で現在の図面上のブロック参照を置き換えるには、置き換え対象のブロック定義を持つ図面をオープン後、ブロック定義を現在の図面にディープクローン、同ブロック定義を元にブロック参照を挿入する必要があります。 この場合、ディープクローン前に現在の図面から置き換え対象のブロック定義と、同ブロック定義を元に挿入されているブロック参照を削除しておく必要があります。   現在の図面（ブロック参照を置き換える図面を図面 A、置き換えるブロック定義を含む外部図面を図面 B とすると、おおまかに次のような手順となります。   図面 A を変数に保存 図面 A 上で対象となるブロック参照数を把握 図面 A 上で対象となるブロック参照の挿入パラメーターをオブジェクト変数に保存 図面 A 上で対象となるブロック参照のを削除 図面 A 上で対象となるブロック定義を削除 ブロック定義をディープクローンするため図面 B をオープン 図面 B 上でディープクローンするブロック定義を変数に保存 対象となるブロック定義を CopyObjects メソッド でディープクローン 図面 B をクローズ ディープクローンしたブロック定義を元に保持したパラメーターで挿入 この実装例は次の通りです。    クラス モジュール（Parameters クラス定義）： Option Explicit ' ブロック参照パラメーター Public X As Double Public Y As Double Public Z As Double Public XS As Double Public YS As Double Public ZS As Double Public R As Double Private Sub Class_Initialize() X = 0# Y = 0# Z = 0# XS = 0# YS = 0# ZS = 0# R = 0# End Sub   プロシージャ： Public Sub ReplaceBlock() ' 図面 A を変数に保存 Dim A As AcadDocument Set A = ThisDrawing.Application.ActiveDocument ' 図面 A 上で対象となるブロック参照数を把握 Dim target As String target = "TEST" Dim entity As AcadEntity Dim block As AcadBlockReference Dim length As Integer length = 0 For Each entity In A.ModelSpace If entity.ObjectName = "AcDbBlockReference" Then Set block = entity If block.Name = target Then length = length + 1 End If End If Next ' 図面 A 上で対象となるブロック参照の挿入パラメーターをオブジェクト変数に保存 Dim index As Integer index = 0 ReDim params(length - 1) As Parameters For Each entity In A.ModelSpace If entity.ObjectName = "AcDbBlockReference" Then Set block = entity If block.Name = target Then Set params(index) = New Parameters params(index).X = block.InsertionPoint(0) params(index).Y = block.InsertionPoint(1) params(index).Z = block.InsertionPoint(2) params(index).XS = block.XScaleFactor params(index).YS = block.YScaleFactor params(index).ZS = block.ZScaleFactor params(index).R = block.Rotation index = index + 1 End If End If Next ' 図面 A 上で対象となるブロック参照のを削除 For Each entity In A.ModelSpace If entity.ObjectName = "AcDbBlockReference" Then Set block = entity If block.Name = target Then block.Delete End If End If Next ' 図面 A 上で対象となるブロック定義を削除 A.Blocks.Item(target).Delete ' ブロック定義をディープクローンするため図面 B をオープン Dim B As AcadDocument Set B = A.Application.Documents.Open("<your_own_path>\B.dwg") ' 図面 B 上でディープクローンするブロック定義を変数に保存 Dim objCollection(0) As Object Set objCollection(0) = B.Blocks.Item(target) ThisDrawing.Application.ActiveDocument = A ' 対象となるブロック定義をディープクローン Dim retObjects As Variant retObjects = B.Database.CopyObjects(objCollection, A.Blocks) ' 図面 B をクローズ B.Close ' ディープクローンしたブロック定義を元に保持したパラメーターで挿入 Dim insertionPnt(0 To 2) As Double For index = 0 To length - 1 insertionPnt(0) = params(index).X insertionPnt(1) = params(index).Y insertionPnt(2) = params(index).Z Set block = A.ModelSpace.InsertBlock(insertionPnt, target, params(index).XS, params(index).YS, params(index).ZS, params(index).R) Next End Sub    

現象 Autocad 2022のVBAでCreateObject("VL.Application.16")を実行すると「実行エラー-2147220999(800701f9): オートメーション　エラーです。DLLでエラーが発生しました」となってします。 同じ処理は、旧バージョンのAutoCADでは問題なく動作をしていました。   解決策 AutoCAD 2022以降のバージョンでは、CreateObject()で"VL.Application.16"を取得できないように変更がされております。VBAのプログラムから、AutoCADのActiveX APIで直接オブジェクトを取得するAPIが存在しないAutoCADのCOMモデル内のオブジェクトを取得する場合には、CreateObject()ではなくAutoCAD ApplicationオブジェクトのGetInterfaceObject メソッド(ActiveX) を利用することを推奨いたします。   今回の場合、以下のサンプルコードの様に変更することで対応が可能です。 なお、以下サンプルコードの変数appはAutoCADのActiveX APIでのApplicationオブジェクトが格納された変数となります。   Set VL = app.GetInterfaceObject("VL.Application.16")  

質問 AutoCAD VBAで、ファイルの保存ダイアログを表示する方法はありますか。   回答 残念ながらAutoCADのActiveX APIにはファイルの保存ダイアログを表示するAPIが提供されておりません。 代替手段としては、Autolipsのgetfiled関数をSendCommand()メソッドを用いて実行することでダイアログを表示する方法があります。   以下はサンプルコードです。 Dim fileName As String ThisDrawing.SendCommand "(setvar " & """users1""" & "(getfiled " & """Save As""" & """c:/program files/acad2024/""" & """dwg""" & "1)) " fileName = ThisDrawing.GetVariable("users1")

Question AutoCADのVBAで、メニューマクロの^C^Cに相当する文字をSendCommandする方法はありますか？ Chr(27)や文字コード27をSendCommandしても、エラーが出て動作しない。 Answer AutoCAD 2015で行われたAutoCADの内部的な実装の変更に起因し、以降のバージョンではChr(27)や文字コード27をSendCommandしてもエラーとなります。 残念ながら、現状ではEscを同期的に実行させる方法はありません。   PostCommandメソッド使用した非同期実行により、代替が可能かをご検討ください。 ThisDrawing.PostCommand Chr(27) & Chr(27)  

Question AutoCAD のActiveX API SetWindowToPlot()で指定した印刷範囲が特定の図面でずれる場合がある。 指定した範囲で正しく印刷する方法はありますか。 Answer 印刷範囲がずれる図面では、TARGETシステム変数の値に0ではない値が設定されている可能性があります。 ※TARGETシステム変数変数については、以下のリファレンスを参照 https://help.autodesk.com/view/ACD/2022/JPN/?guid=GUID-0649E4B8-B11A-411E-96CE-125BEBEB5B42   この場合、SetWindowToPlotで指定した座標がオフセットされてるため、指定した印刷範囲で印刷されません。 以下サンプルコードの様にSetWindowToPlot()に指定する点の座標を、ActiveViewport.Targetの値で減算することで、指定範囲で印刷されるようになります。   Sub Example_SetWindowToPlot() Dim point1 As Variant, point2 As Variant point1 = ThisDrawing.Utility.GetPoint(, "Click the lower-left of the window to plot.") ReDim Preserve point1(0 To 1) ' Change this to a 2D array by removing the Z position point2 = ThisDrawing.Utility.GetPoint(, "Click the upper-right of the window to plot.") ReDim Preserve point2(0 To 1) ' Change this to a 2D array by removing the Z position Dim currTarget As Variant currTarget = ThisDrawing.ActiveViewport.Target point1(0) = point1(0) - currTarget(0) point1(1) = point1(1) - currTarget(1) point2(0) = point2(0) - currTarget(0) point2(1) = point2(1) - currTarget(1) ThisDrawing.ActiveLayout.SetWindowToPlot point1, point2 ThisDrawing.ActiveLayout.PlotType = acWindow ThisDrawing.ActiveLayout.ConfigName = "DWG to PDF.pc3" ThisDrawing.Plot.DisplayPlotPreview acFullPreview End Sub