координаты/атрибуты блока в excel???

Option Explicit
' by Fatty 2007
' Request reference to Microsoft Office 11.0 Object Library
Dim oSset As AcadSelectionSet
Sub WriteBlocks()
     Dim xlApp As Excel.Application
     Dim xlBook As Workbook
     Dim xlSheet As Worksheet
     Dim xlPath As String
     xlPath = ThisDrawing.Path & "\MyBlocks2.xls"
     On Error Resume Next
     Err.Clear
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
          Err.Clear
          Set xlApp = CreateObject("Excel.Application")
          If Err <> 0 Then
               MsgBox "Cannot start Excel", vbExclamation
               End
          End If
     End If
     On Error GoTo Err_Control
     xlApp.Visible = False
     Set xlBook = xlApp.Workbooks.Add
     Set xlSheet = xlBook.Worksheets(1)
     Dim fcode(1) As Integer
     Dim fData(1) As Variant
     Dim dxfcode, dxfdata
     Dim i As Long, j As Long, k As Long
     Dim setName As String
     Dim blkRef As AcadBlockReference
     Dim oEnt As AcadEntity
     Dim ins As Variant
     Dim attVar() As AcadAttributeReference
     Dim objAtt As AcadAttributeReference
     fcode(0) = 0
     fData(0) = "INSERT"
     fcode(1) = 66
     fData(1) = 1
     dxfcode = fcode
     dxfdata = fData
     setName = "$Blocks$"
     For i = 0 To ThisDrawing.SelectionSets.Count - 1
          If ThisDrawing.SelectionSets.Item(i).Name = setName Then
               ThisDrawing.SelectionSets.Item(i).Delete
               Exit For
          End If
     Next i
     Set oSset = ThisDrawing.SelectionSets.Add(setName)
     oSset.SelectOnScreen dxfcode, dxfdata
     MsgBox oSset.Count
     j = 1
     k = 1
     For Each oEnt In oSset
          Set blkRef = oEnt
          ins = blkRef.InsertionPoint
          attVar = blkRef.GetAttributes
          xlSheet.Cells(j, 1) = "BLOCK #" & CStr(k)
          xlSheet.Cells(j + 1, 1) = "BLOCK NAME:"
          xlSheet.Cells(j + 1, 2) = blkRef.Name
          xlSheet.Cells(j + 2, 1) = CStr(Replace(CStr(ins(0)), ".", ",", 1, -1))
          xlSheet.Cells(j + 2, 2) = CStr(Replace(CStr(ins(1)), ".", ",", 1, -1))
          xlSheet.Cells(j + 2, 3) = CStr(Replace(CStr(ins(2)), ".", ",", 1, -1))
          j = j + 3
          For i = 0 To UBound(attVar)
               Set objAtt = attVar(i)
               xlSheet.Cells(j, 1) = objAtt.TagString
               xlSheet.Cells(j, 2) = objAtt.TextString
               j = j + 1
          Next i
          j = j + 1
          k = k + 1
     Next oEnt
Exit_Here:
     xlSheet.UsedRange.Columns.AutoFit
     xlBook.SaveAs xlPath, , , , False
     xlBook.Close
     xlApp.Quit
     Exit Sub
Err_Control:
     If Err.Number <> 0 Then
          MsgBox Err.Number & " --> " & Err.Description
     Else
          MsgBox "Done"
     End If
     Set xlApp = Nothing
     Set xlBook = Nothing
     Set xlSheet = Nothing
     Resume Exit_Here
End Sub

Option Explicit
' by Fatty 2007
' Request reference to Microsoft Office 11.0 Object Library
Dim oSset As AcadSelectionSet
Sub WriteBlocks()
     Dim xlApp As Excel.Application
     Dim xlBook As Workbook
     Dim wbkobjs As Workbooks
     Dim xlSheet As Worksheet
     Dim shtobjs As Worksheets
     Dim xlPath As String
     xlPath = ThisDrawing.Path & "\MyBlocks2.xls"
     On Error Resume Next
     Err.Clear
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
          Err.Clear
          Set xlApp = CreateObject("Excel.Application")
          If Err <> 0 Then
               MsgBox "Cannot start Excel", vbExclamation
               End
          End If
     End If
     On Error GoTo Err_Control
     xlApp.Visible = False
     Set xlBook = xlApp.Workbooks.Add
     Set xlSheet = xlBook.Worksheets(1)
     Dim fcode(1) As Integer
     Dim fData(1) As Variant
     Dim dxfcode, dxfdata
     Dim i As Long, j As Long, k As Long
     Dim setName As String
     Dim blkRef As AcadBlockReference
     Dim oEnt As AcadEntity
     Dim oText As AcadText
     Dim ins As Variant
     Dim upt As Variant
     Dim dblHgt As Double
     Dim attVar() As AcadAttributeReference
     Dim objAtt As AcadAttributeReference
     fcode(0) = 0
     fData(0) = "INSERT"
     fcode(1) = 66
     fData(1) = 1
     dxfcode = fcode
     dxfdata = fData
     setName = "$Blocks$"
     For i = 0 To ThisDrawing.SelectionSets.Count - 1
          If ThisDrawing.SelectionSets.Item(i).Name = setName Then
               ThisDrawing.SelectionSets.Item(i).Delete
               Exit For
          End If
     Next i
     Set oSset = ThisDrawing.SelectionSets.Add(setName)
     oSset.SelectOnScreen dxfcode, dxfdata
     MsgBox oSset.Count
     j = 1
     k = 1
     dblHgt = ThisDrawing.GetVariable("DIMTXT") ' change text height you need
     For Each oEnt In oSset
          Set blkRef = oEnt
          ins = blkRef.InsertionPoint
          Set oText = ThisDrawing.ModelSpace.AddText(CStr(k), ins, dblHgt)
          oText.color = acYellow
          upt = ThisDrawing.Utility.TranslateCoordinates(ins, acWorld, acUCS, False)
          attVar = blkRef.GetAttributes
          xlSheet.Cells(j, 1) = "BLOCK #" & CStr(k)
          xlSheet.Cells(j + 1, 1) = "BLOCK NAME:"
          xlSheet.Cells(j + 1, 2) = blkRef.Name
          xlSheet.Cells(j + 2, 1) = CStr(Replace(CStr(upt(0)), ".", ",", 1, -1))
          xlSheet.Cells(j + 2, 2) = CStr(Replace(CStr(upt(1)), ".", ",", 1, -1))
          xlSheet.Cells(j + 2, 3) = CStr(Replace(CStr(upt(2)), ".", ",", 1, -1))
          j = j + 3
          For i = 0 To UBound(attVar)
               Set objAtt = attVar(i)
               xlSheet.Cells(j, 1) = objAtt.TagString
               xlSheet.Cells(j, 2) = objAtt.TextString
               j = j + 1
          Next i
          j = j + 1
          k = k + 1
     Next oEnt
Exit_Here:
     xlSheet.UsedRange.Columns.AutoFit
     xlBook.SaveAs xlPath, , , , False
     xlBook.Close
     xlApp.Quit
     Exit Sub
Err_Control:
     If Err.Number <> 0 Then
          MsgBox Err.Number & " --> " & Err.Description
     Else
          MsgBox "Done"
     End If
     Set xlApp = Nothing
     Set xlBook = Nothing
     Set wbkobjs = Nothing
     Set xlSheet = Nothing
     Set shtobjs = Nothing
     Resume Exit_Here
End Sub