向excel autocad请求特定数据

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
    Dim Count As Integer
    Dim SHand As String
    Dim TStr As String
     
    Set Excel = GetObject(, "Excel.Application")
    Worksheets("Attributes").Activate
    Set excelSheet = Excel.ActiveWorkbook.Sheets("Attributes")
    excelSheet.Range(Cells(1, 1), Cells(5000, 100)).Clear
    excelSheet.Range(Cells(1, 1), Cells(1, 100)).Font.Bold = True
    Set acad = Nothing
    On Error Resume Next
    Set acad = GetObject(, "AutoCAD.Application")
    If Err  0 Then
        Set acad = CreateObject("AutoCAD.Application")
        MsgBox "Open the drawing file first and then rexecute!"
        Exit Sub
    End If
    acad.Visible = True
    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
                    For Count = LBound(Array1) To UBound(Array1)
                        If Header = False Then
                            If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then
                                TStr = Array1(Count).TagString
                                excelSheet.Cells(RowNum, Count + 1).Value = TStr
                            End If
                        End If
                    Next Count
                    RowNum = RowNum + 1
                    For Count = LBound(Array1) To UBound(Array1)
                        TStr = Array1(Count).TextString
                        excelSheet.Cells(RowNum, Count + 1).Value = TStr
                    Next Count
                    SHand = elem.Handle
                    excelSheet.Cells(RowNum, Count + 1).NumberFormat = "@"
                    excelSheet.Cells(RowNum, Count + 1).Value = SHand
                    Header = True
                End If
            End If
        End With
    Next elem
    NumberOfAttributes = RowNum - 1
    Set acad = Nothing
End Sub