Вывод данных атрибутов блока

;;local defun
;; make table style
;; (minimal list of options)
(defun make-tablestyle ( name desc txtstyle h1 h2 h3 / tblstyle adoc)
  (or (vl-load-com))
  (setq
    tblstyle (vla-addobject
      (vla-item (vla-get-dictionaries
             (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
             )
           "Acad_Tablestyle"
           )
      name
      "AcDbTableStyle"
      )
    )
  (setq acmCol (vla-getinterfaceobject
           (vlax-get-acad-object)
           (strcat "AutoCAD.AcCmColor."
               (substr (getvar "ACADVER") 1 2))))
  (vla-put-name tblstyle name)
  (vla-put-headersuppressed tblstyle :vlax-false)
  (vla-put-titlesuppressed tblstyle :vlax-false)
  (vla-put-description tblstyle desc)
  (vla-put-flowdirection tblstyle 0)
  (vla-put-bitflags tblstyle 1)
  (vla-put-horzcellmargin tblstyle (/ h3 5))
  (vla-put-vertcellmargin tblstyle (/ h3 5))
  (vla-settextstyle tblstyle 7 txtstyle)
;;;  (vla-settextstyle tblstyle 4 txtstyle)
;;;  (vla-settextstyle tblstyle 1 txtstyle)
  (vla-settextheight tblstyle 1 h3)
  (vla-settextheight tblstyle 4 h2)
  (vla-settextheight tblstyle 2 h1)
  (vla-setrgb acmCol 204 102 0)
;;;  (vla-put-colorindex acmCol 32)
  (vla-setgridcolor tblstyle 63 7 acmCol)
  (vla-setgridvisibility tblstyle 63 7 :vlax-true)
  (vla-setgridlineweight  tblstyle 18 7 aclnwt009)
  (vla-setgridlineweight tblstyle 45 7 aclnwt050)
  (vlax-release-object acmCol)
  )
;=========== * main part  * ===========;
(defun C:BTA (/ ad an atval axss dht en heads objtable tagname vals)
  (if (< (atof (getvar "ACADVER")) 16.0)
  (alert "This routine will work only\nfor versions A2005 and higher")
  (progn
  (alert "\tBe patience\n\tWorks slowly")
  (vl-load-com)
  (or adoc
    (setq adoc (vla-get-activedocument
  (vlax-get-acad-object))))
  (or acsp (setq acsp (if (= (getvar "TILEMODE") 0)
  (vla-get-paperspace
  adoc)
  (vla-get-modelspace
  adoc))
  )
  )
  (make-tablestyle "Block-Info" "Block table" "Standard" 10.0 10.0 12.0)
  (setq acmCol (vla-getinterfaceobject
           (vlax-get-acad-object)
           (strcat "AutoCAD.AcCmColor."
               (substr (getvar "ACADVER") 1 2))))
  (setq dht (getvar "dimtxt"))
  (setq heads nil vals nil)
  (setq ss (ssget "+.:S:E" '((0 . "INSERT")(66 . 1))))
  (setq en (ssname ss 0)
    nm (cdr (assoc 2 (entget en)))
        an (entnext en))
  (while (= "ATTRIB" (cdr (assoc 0 (entget an))))
         (setq ad (entget an))
               (setq tagname (cdr (assoc 2 ad)))
               (setq atval (cdr (assoc 1 ad)))
(setq heads (cons tagname heads))
    (setq vals (cons atval vals))
          (setq an (entnext an))
  )
  (setq heads (append (list "Block Name") (reverse  heads))
    vals (append (list nm) (reverse vals))
    )
(setq table_data (append (list heads) (list vals)))
(setq desc_wid (* (getvar "dimtxt")(apply 'max (mapcar 'strlen (car table_data)))))
(setq    columns     (length (car table_data))
    rows     2
  )
(setq    objtable (vlax-invoke
         acsp
         'Addtable
         (getpoint "\nUpper left table insertion point: \n")
         (1+ rows)
         columns
         ;; rows height (change by suit):
         (* dht 2)
         ;; columns width (change by suit):
         desc_wid
           )
  )
  (vla-put-regeneratetablesuppressed objtable :vlax-true)
  (vla-put-layer objtable "0")
  (vla-put-titlesuppressed objtable :vlax-false)
  (vla-put-headersuppressed objtable :vlax-false)
  (vla-put-horzcellmargin objtable (* dht 0.5))
  (vla-put-vertcellmargin objtable (* dht 0.5))
  (vla-settextstyle objtable acTitleRow "Standard")
  (vla-settextstyle objtable acHeaderRow "Standard")
  (vla-settextstyle objtable acDataRow "Standard")
  (vla-setrowheight objtable 2 (* dht 1.75))
  (vla-setrowheight objtable 1 (* dht 1.5))
  (vla-setrowheight objtable 0 (* dht 1.75))
  (vla-settextheight objtable acTitleRow (* dht 1.25))
  (vla-settextheight objtable acHeaderRow dht)
  (vla-settextheight objtable acDataRow dht)
  (vla-put-colorindex acmcol 160)
  (vla-put-truecolor objtable acmcol)
  (setq col 0)
  (foreach a (car table_data)
  (vla-setcolumnwidth objtable col desc_wid)
    (setq col (1+ col))
    )
  (vla-put-colorindex acmcol 2)
  (vla-settext objtable 0 0 (strcat "Table Data Of Block" (vl-prin1-to-string nm))) ;(change by suit)
  (vla-setcelltextheight objtable 0 0 (* dht 1.5))
  (vla-setcellcontentcolor objtable 0 0 acmcol)
  (vla-put-colorindex acmcol 102)
  (setq    headers    (car table_data))
  (setq    col 0
    row 1
  )
  (foreach a headers
    (vla-settext objtable row col a)
    (vla-setcelltextheight objtable row col (* dht 1.25))
    (vla-setcellcontentcolor objtable row col acmcol)
    (setq col (1+ col))
  )
(vla-put-colorindex acmcol 12)
(setq lst_count (cdr table_data) row 2 col 0)
  (setq cnt 0 row 2)
  (foreach i lst_count
  (setq col 0)
  (foreach a i
    (vla-settext objtable row col a)
    (vla-setcellalignment objtable row col acMiddleLeft)
    (vla-setcellcontentcolor objtable row col acmcol)
    (setq col (1+ col)))
    (setq row (1+ row))
    )
  (vla-put-regeneratetablesuppressed objtable :vlax-false)
  (vl-catch-all-apply
    (function
      (lambda ()
    (progn
      (vla-clear axss)
      (vla-delete axss)
      (mapcar 'vlax-release-object (list axss objtable))
      )
    )
      )
    )
  (vla-regen adoc acactiveviewport)
  (alert "Done")
  )
)
  (princ)
)
(prompt
  "\n\t\t\t   |-----------------------------|\n"
)
(prompt
  "\n\t\t\t  <|  Start with BTA to execute  |>\n"
)
(prompt
  "\n\t\t\t   |-----------------------------|\n"
)
; TesT : (C:BTA)

Private Sub MakeTableStyle()
' creates a TableStyle object
     Dim oDict As AcadDictionary
     Dim aColor As New AcadAcCmColor
     Dim oTblSty As AcadTableStyle
     Dim sKeyName As String
     Dim sClassName As String
     'grab the tablestyle dictionary object
     Set oDict = ThisDrawing.Database.Dictionaries.Item("acad_tablestyle")
     sKeyName = "Block Table"
     sClassName = "AcDbTableStyle"
     'create the TableStyle object in the dictionary
     Set oTblSty = oDict.AddObject(sKeyName, sClassName)
     With oTblSty
          .Name = "Excel2Table"
          .Description = "Style For The Block Info"
          .HorzCellMargin = 0.22
          .TitleSuppressed = False
          .SetTextHeight 3, 1.3
          .SetGridVisibility 3, 3, True
          .SetAlignment 3, acMiddleCenter
          aColor.SetRGB 244, 0, 0
     End With
End Sub
Sub BlockToTable()
     Dim oTable As AcadTable
     Dim oEnt As AcadEntity
     Dim blkRef As AcadBlockReference
     Dim varPt As Variant
     Dim attVar() As Object
     Dim attObj As AcadAttributeReference
     Dim row As Long, col As Long
     Dim i As Long, j As Long
     Dim tmpStr As String
     Dim acCol As New AcadAcCmColor
     On Error Resume Next
     ThisDrawing.Utility.GetEntity oEnt, varPt, vbCrLf & "Select block to import data to table"
     If Err Then
          Err.Clear
     End If
     On Error GoTo 0
     If Not oEnt Is Nothing Then
          If TypeOf oEnt Is AcadBlockReference Then
               Set blkRef = oEnt
          End If
     End If
     If Not blkRef.HasAttributes Then
          MsgBox "This block does not have an attributes"
          Exit Sub
     End If
     attVar = blkRef.GetAttributes
     ReDim blkdata(0 To UBound(attVar) + 1, 0 To 1) As String
     blkdata(0, 0) = "Block Name"
     If blkRef.IsDynamicBlock Then
          blkdata(0, 1) = blkRef.EffectiveName
     Else
          blkdata(0, 1) = blkRef.Name
     End If
     For i = 0 To UBound(attVar)
          Set attObj = attVar(i)
          blkdata(i + 1, 0) = attObj.TagString
          blkdata(i + 1, 1) = attObj.TextString
     Next i
     Dim pt(2) As Double
     pt(0) = 0: pt(1) = 0: pt(1) = 0:
     Call MakeTableStyle
     Set oTable = ThisDrawing.ModelSpace.AddTable(pt, 3, UBound(blkdata, 1) + 1, 5, 30)
     oTable.RegenerateTableSuppressed = True
     oTable.HorzCellMargin = 0.5
     oTable.TitleSuppressed = False
     oTable.HeaderSuppressed = False
     oTable.SetTextHeight 7, 1.6875
     row = 0
     col = 0
     acCol.SetRGB 143, 189, 164
     tmpStr = "Block Attributes Info"
     oTable.SetRowHeight row, 22.5
     oTable.SetCellTextHeight row, col, 10
     oTable.SetCellBackgroundColor row, col, acCol
     acCol.SetRGB 173, 43, 0
     oTable.SetCellContentColor row, col, acCol
     oTable.SetText row, col, tmpStr
     oTable.SetCellAlignment row, col, acMiddleCenter
     row = 1
     col = 0
     oTable.SetRowHeight row, 15
     For i = 0 To UBound(blkdata, 1)
          acCol.SetRGB 236, 237, 238
          oTable.SetCellTextHeight row, col, 7.5
          oTable.SetCellBackgroundColor row, col, acCol
          acCol.SetRGB 0, 0, 180
          oTable.SetCellContentColor row, col, acCol
          tmpStr = blkdata(i, 0)
          oTable.SetColumnWidth i, 80#
          oTable.SetText row, col, tmpStr
          oTable.SetCellAlignment row, col, acMiddleCenter
          acCol.SetRGB 0, 0, 180
          col = col + 1
     Next
     row = 2
     col = 0
     oTable.SetRowHeight row, 15
     For i = 0 To UBound(blkdata, 1)
          acCol.SetRGB 236, 237, 238
          oTable.SetCellTextHeight row, col, 7.5
          oTable.SetCellBackgroundColor row, col, acCol
          acCol.SetRGB 0, 0, 180
          oTable.SetCellContentColor row, col, acCol
          tmpStr = blkdata(i, 1)
          oTable.SetText row, col, tmpStr
          oTable.SetCellAlignment row, col, acMiddleCenter
          col = col + 1
     Next
     oTable.RegenerateTableSuppressed = False
     Set acCol = Nothing
End Sub

Sub test()
Dim oSSet As AcadSelectionSet
dim fType(1) as Integer
dim fData(1) as Variant
fType(0) = 0: fData(0) = "INSERT"
fType(1) = 2: fData(1) = myblockname '// имя твоего блока
On Error Goto Err_Control
Set oSSet = ThisDrawing.SelectionSets.add("DummySetName")
oSSet.Select acSelectionSetAll, , , fType, fData
If oSSet.Count=1 Then
dim blkRef as AcadBlockReference
set blkref=oSSet.item(0)
<<работаешь с блоком>>
Elseif oSSet.count > 1 then
For each blkref in oSSet
<<работаешь с каждым блоком>>
Next
elseif oSSet.count = 0 then
msgbox "No such blocks in this drawing"
exit sub
end if
oSSet.Clear
oSSet.delete
Err_Control:
end sub

fType(0) = 0: fData(0) = "INSERT"
fType(1) = 2: fData(1) = myblockname '// имя твоего блока
On Error Goto Err_Control
Set oSSet = ThisDrawing.SelectionSets.add("DummySetName")
oSSet.Select acSelectionSetAll, , , fType, fData