EXCEL获得CAD块属性

Sub dd()
Dim cName As String
Dim nHandle As String
Dim nScale As Double
Dim nRotation As Double
Dim sLayer As String
Dim yline As Integer
Dim ent As Object
Dim obname As String
Dim xy As Variant
Dim varattr As Variant
Dim attrtxt As Variant
    On Error Resume Next

Dim Excel As Object
    Dim ExcelSheet   As Object
    Dim ExcelWorkbook   As Object
    '创建Excel应用程序实例
  
    On Error Resume Next
    Set Excel = GetObject(, "Excel.Application")
     Set ExcelSheet = Excel.ActiveSheet
    Excel.Visible = True
   

yline = 2 '写入行位置
For Each ent In ThisDrawing.ModelSpace '在模型空间里循环
  obname = ent.ObjectName '提取对象类型
  If obname = "AcDbBlockReference" Then '判断对象是否为块
    cName = ent.Name        '获取块名
    xy = ent.InsertionPoint '获取插入点坐标
    nHandle = ent.Handle    '获取块句柄
    nScale = ent.XScaleFactor     '获取比例
    nRotation = ent.Rotation '获取角度
    sLayer = ent.Layer
   
    varattr = ent.GetAttributes ' 将块属性标记和值复制到varattr变量
    attrtxt(0) = varattr(0).TextString '属性值 0
    attrtxt(1) = varattr(1).TextString '属性值 1
    attrtxt(2) = varattr(2).TextString '属性值 2
   
    ExcelSheet.Cells(yline, 1).Value = nHandle
    ExcelSheet.Cells(yline, 2).Value = cName
    ExcelSheet.Cells(yline, 3).Value = xy(0)
    ExcelSheet.Cells(yline, 4).Value = xy(1)
    ExcelSheet.Cells(yline, 5).Value = xy(2)
    ExcelSheet.Cells(yline, 6).Value = obname
    ExcelSheet.Cells(yline, 7).Value = nScale
    ExcelSheet.Cells(yline, 8).Value = nRotation
    ExcelSheet.Cells(yline, 9).Value = sLayer
    ExcelSheet.Cells(yline, 10).Value = attrtxt(0)  '属性值 0 写入excle文件
    ExcelSheet.Cells(yline, 11).Value = attrtxt(1)  '属性值 1 写入excle文件
    ExcelSheet.Cells(yline, 12).Value = attrtxt(2)  '属性值 1 写入excle文件
    yline = yline + 1 '位置加一行
    attrtxt(0) = ""
    attrtxt(1) = ""
    attrtxt(2) = ""

   End If
Next
Excel.Visible = True
Set Excel = Nothing '释放变量
Set ExcelSheet = Nothing
End Sub