Актуально. Получение списка блоков в Excelle(VB)

Option Explicit
Dim thisdrawing As Object
Dim blkVar()
Dim total As Long
Public Sub GetCensus()
Dim oAutoCad As Object
Dim oModelSpace As Object
Dim wksCensus As Worksheet
Dim intI As Integer
' Get the open instance of AutoCAD
Set oAutoCad = GetObject(, "AutoCAD.Application")
If Not oAutoCad Is Nothing Then
Set thisdrawing = oAutoCad.ActiveDocument
Call CountBlocks
Set wksCensus = Worksheets("Census")
wksCensus.Range("A2", "E1000").Clear
'Set oModelSpace = oAutoCad.ActiveDocument.ModelSpace
For intI = LBound(blkVar, 1) To UBound(blkVar, 1)
'With oModelSpace.Item(intI)
wksCensus.Cells(intI + 2, 1) = blkVar(intI, 0)
wksCensus.Cells(intI + 2, 2) = blkVar(intI, 1)
total = total + blkVar(intI, 1)
'wksCensus.Cells(intI + 2, 3) = .Color
'wksCensus.Cells(intI + 2, 4) = .Layer
'wksCensus.Cells(intI + 2, 5) = .Linetype
'End With
Next intI
wksCensus.Cells(3, 3) = oAutoCad.ActiveDocument.Name
wksCensus.Cells(4, 3) = total & " total blocks"
End If
End Sub
Private Sub CountBlocks()
' by Fatty T.O.H ()2007 * all rights removed
' not working with dynamic blocks
  Dim oBlocks As AcadBlocks
  Dim oBlock As AcadBlock
  Dim oBlkRef As AcadBlockReference
  Dim oEnt As AcadEntity
  Dim fType(1) As Integer, fData(1)
  Dim oSset As AcadSelectionSet
  Dim blkName As String
  Dim iCount As Integer
  Dim dxfCode, dxfData
  Dim tmp(1)
  Dim blkColl As New Collection
  fType(0) = 0: fData(0) = "INSERT"
  fType(1) = 2
On Error GoTo Err_Trapp
          With thisdrawing.SelectionSets
               While .Count > 0
                    .Item(0).Delete
               Wend
          End With
Set oSset = thisdrawing.SelectionSets.Add("$BlkInstances$")
oSset.Clear
Set oBlocks = thisdrawing.Blocks
  'loop through all block definitions
  For Each oBlock In oBlocks
  If oBlock.IsLayout = False And oBlock.IsXRef = False Then
  blkName = oBlock.Name
  fData(1) = blkName
  dxfCode = fType
  dxfData = fData
  oSset.Select acSelectionSetAll, , , dxfCode, dxfData
  iCount = 0
  For Each oBlkRef In oSset
  iCount = iCount + 1
    Next oBlkRef
    tmp(0) = blkName: tmp(1) = iCount
    If iCount > 0 Then
    blkColl.Add tmp
    End If
    Erase tmp
    oSset.Clear
    End If
  Next oBlock
  Debug.Print "Used Block Definitions: " & blkColl.Count
  oSset.Delete
  Set oSset = Nothing
  ' convert collection to two-dimensional array
  Dim i As Long, j As Long
  ReDim blkVar(blkColl.Count - 1, 1)
  For i = 1 To blkColl.Count
  blkVar(i - 1, 0) = blkColl.Item(i)(0)
  blkVar(i - 1, 1) = blkColl.Item(i)(1)
  Next
Err_Trapp:
If Err Then
 MsgBox "Error occured:" & vbNewLine & Err.Description
 End If
End Sub

Option Explicit
Dim oAutoCad As Object
Dim aDoc As Object
Dim oModelSpace As Object
Dim wksCensus As Object
Dim intI As Long
Dim total As Long
Sub countB()
Dim arrBlk() As Variant
Dim i As Long, j As Long
Dim cnt As Integer, k As Integer
Dim gotcha As Boolean
Set oAutoCad = GetObject(, "AutoCAD.Application")
If Not oAutoCad Is Nothing Then
  Set aDoc = oAutoCad.ActiveDocument
End If
cnt = aDoc.ModelSpace.count
    i = 0: total = 0
    For k = 0 To cnt - 1
        If aDoc.ModelSpace.Item(k).ObjectName = _
"AcDbBlockReference" Then
            j = 1
            gotcha = False
            While j <= i
                If arrBlk(0, j) = _
                   aDoc.ModelSpace.Item(k).Name Then
                    arrBlk(1, j) = arrBlk(1, j) + 1
                    j = i
                    gotcha = True
                End If
                j = j + 1
            Wend
            If Not gotcha Then
                i = i + 1
                ReDim Preserve arrBlk(2, i)
                arrBlk(0, i) = aDoc.ModelSpace.Item(k).Name
                arrBlk(1, i) = 1
            End If
        End If
    Next k
ReDim arrData(0 To UBound(arrBlk, 2) - 1, 0 To 1)
For k = 1 To UBound(arrBlk, 2)
    arrData(k - 1, 0) = arrBlk(0, k)
    arrData(k - 1, 1) = arrBlk(1, k)
Next k
Set wksCensus = ThisWorkbook.Worksheets("Census")
With wksCensus
  .Range("A2", "E1000").Clear
  .Range("1:1").Font.Bold = True
  .Cells(1, 1).Value = "Block Name"
  .Cells(1, 2).Value = "Quantity:"
  .Cells(1, 3).Value = "Total:"
For intI = LBound(arrData, 1) To UBound(arrData, 1)
  .Cells(intI + 2, 1).Value = arrData(intI, 0)
  .Cells(intI + 2, 2).Value = arrData(intI, 1)
  total = total + arrData(intI, 1)
Next intI
  .Cells(3, 3).Value = oAutoCad.ActiveDocument.Name
  .Cells(4, 3).Value = CStr(total) & " total blocks"
  .Range("A:C").Columns.AutoFit
End With
MsgBox "Holy crap, do you got it to work?!" & vbCr & "I can't believe it!"
Set aDoc = Nothing
Set oAutoCad = Nothing
End Sub

If aDoc.ModelSpace.Item(k).ObjectName = _
"AcDbBlockReference" Then