cad vba提取块名属性方法

1

1. 使用 VBA IDE 中的“工具”“引用”菜单选项，选择 Microsoft Excel 8.0/ Microsoft Excel 12.0对象模型。

2. Sub Ch12_Extract()

       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

       

       ' 启动 Excel。

       Set Excel = New Excel.Application

       

       ' 创建新的工作簿并查找活动电子表格。

       Set ExcelWorkbook = Excel.Workbooks.Add

       Set ExcelSheet = Excel.ActiveSheet

       ExcelWorkbook.SaveAs "Attribute2.xls"

       

       RowNum = 1

       Header = False

       ' 遍历模型空间，查找

       ' 所有的块引用。

       For Each elem In ThisDrawing.ModelSpace

           With elem

               ' 找到块引用时，

               ' 检查其属性

               If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then

                   If .HasAttributes Then

                       ' 获取属性

                       Array1 = .GetAttributes

                       ' 将属性的标记字符串

                       ' 复制到 Excel

                       For Count = LBound(Array1) To UBound(Array1)

                           If Header = False Then

                               If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then

                                   ExcelSheet.Cells(RowNumCount + 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