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