7.1 提出AutoCAD图块属性到Excel中
我们在制图的时通常把具有同一属性格式的单元或常用的部分在AutoCAD中制成图块并附以属性值,这样我们在以后的制图过程中遇到与此图块相同类型的图形时直接插入此图块就可以了,有时候我们要把这些图块的属性以列表形式表示以备我们查阅.Excel电子表格具有强大的计算功能，我们可以把属性值提取到Excel中并加以整理。
7.1.1引用Excel, AutoCAD对象

Public acad As Object
Public mspace As Object
Public excel As Object
Public AcadRunning As Integer
Public excelSheet As Object
Sub Extract()
    Dim sheet As Object
    Dim shapes As Object
    Dim elem As Object
    Dim excel As Object
    Dim Max As Integer
    Dim Min As Integer
    Dim NoOfIndices As Integer
    Dim excelSheet As Object
    Dim RowNum As Integer
    Dim Array1 As Variant, Array2 As Variant
    Dim Count As Integer



    Set excel = GetObject(, "Excel.Application")
Set  excelSheet = excel. Worksheets("sheet1")
     Dim Sh As Object, rngStart As Range
     If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
     Set Sh1 = ExcelSheet1
Set rngStart = Sh1.Range("A1")
    With rngStart.Rows(1)
End With
    Set acad = Nothing
    On Error Resume Next
    Set acad = GetObject(, "AutoCAD.Application")
    If Err <> 0 Then
    Set acad = CreateObject("AutoCAD.Application")
    MsgBox "请打开 AutoCAD 图形文件!"
    Exit Sub
    End If

    Set doc = acad.ActiveDocument
    Set mspace = doc.ModelSpace
    RowNum = 1
    Dim Header As Boolean
    Header = False
    For Each elem In mspace
      With elem
        If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
           If .HasAttributes Then
              Array1 = .GetAttributes
              Array2 = .GetConstantAttributes
            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
            
            For Count = LBound(Array2) To UBound(Array2)
               If Header = False Then
                 If StrComp(Array2(Count).EntityName, "AcDbAttributeDefinition", 1) = 0 Then
                  excelSheet.Cells(RowNum, UBound(Array1) + 1 + Count + 1).Value = Array2(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
            
            For Count = LBound(Array2) To UBound(Array2)
               excelSheet.Cells(RowNum, UBound(Array1) + 1 + Count + 1).Value = Array2(Count).TextString
            Next Count
            
            Header = True
            End If
          End If
      End With
    Next elem
    NumberOfAttributes = RowNum - 1
    If NumberOfAttributes > 0 Then
      Worksheets("属性取出").Range("A1").Sort _
      key1:=Worksheets("属性取出").Columns("A"), _
      Header:=xlGuess
    Else
      MsgBox "无法提出图形文件中的属性或此图形文件中无任何属性！"
    End If
    
    Set currentcell = Range("A2")
    Do While Not IsEmpty(currentcell)
        Set nextCell = currentcell.Offset(1, 0)
        If nextCell.Value = currentcell.Value Then
            Set TCell = currentcell.Offset(1, 3)
            TCell.Value = TCell.Value + 1
            currentcell.EntireRow.Delete
        End If
        Set currentcell = nextCell
    Loop

    
    Set acad = Nothing
End Sub