例: AutoCAD 属性を Excel のスプレッドシートにリストする(VBA/ActiveX)

このサンプル サブルーチンでは現在の図面内のすべてのブロック参照を検索します。

次に、それらのブロック参照にアタッチされた属性を見つけ、それらを Excel のスプレッドシートにリストします。この例を実行するには

1. 属性付きのブロック参照を持つ図面を開きます(サンプル図面 sample¥activeX¥attrib.dwg に、このようなブロック参照があります)。
2. AutoCAD のコマンド プロンプトに対して VBAIDE と入力し、[Enter]を押します。

   VBA IDE が表示されます。

3. VBA IDE のメニュー バーで、[ツール]メニュー [参照設定]をクリックします。
4. [参照設定]ダイアログ ボックスで、[Microsoft Excel <バージョン番号> Object Model]を選択します。[OK]をクリックします。
5. 次のサブルーチンを VBA コード ウィンドウにコピーし、実行します。

   Sub ExtractAtts()
     Dim Excel As Excel.Application
     Dim ExcelSheet As Object
     Dim ExcelWorkbook As Object
   
     Dim RowNum As Integer
     Dim Header As Boolean
     Dim elem As AcadEntity
     Dim Array1 As Variant
     Dim Count As Integer
   
     ' Launch Excel.
     Set Excel = New Excel.Application
   
     ' Create a new workbook and find the active sheet.
     Set ExcelWorkbook = Excel.Workbooks.Add
     Set ExcelSheet = Excel.ActiveSheet
     ExcelWorkbook.SaveAs "Attribute.xls"
   
     RowNum = 1
     Header = False
   
     ' Iterate through model space finding
     ' all block references.
     For Each elem In ThisDrawing.ModelSpace
       With elem
         ' When a block reference has been found,
         ' check it for attributes
         If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
           If .HasAttributes Then
             ' Get the attributes
             Array1 = .GetAttributes
   
             ' Copy the Tagstrings for the
             ' Attributes into Excel
             For Count = LBound(Array1) To UBound(Array1)
               If Header = False Then
                 If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then
                   ExcelSheet.Cells(RowNum, Count + 1).value = Array1(Count).TagString
                 End If
               End If
             Next Count
   
             RowNum = RowNum + 1
             For Count = LBound(Array1) To UBound(Array1)
               ExcelSheet.Cells(RowNum, Count + 1).value = Array1(Count).textString
             Next Count
   
             Header = True
           End If
         End If
       End With
     Next elem
     Excel.Application.Quit
   End Sub