[编程申请：关于块属性的编程！

zwx123

在下通常将常见的设备都制作成块，绘图时插入即可，非常方便。
    制作的块一般有四个附加属性，即Tag1～Tag4对应值分别是设备名称、规格型号、使用位置、备注（使用要求、厂家等描述）。
    希望编程将四个Tag对应的四个Value值提取出来，然后导入Excel。
请大侠们帮忙，小弟不胜感激！

lsjjm

提取属性请参考:
(defun GetAttributes (blk / lst)
  (vl-load-com)
  (if (safearray-value
        (setq lst (vlax-variant-value
                    (vla-getattributes (vlax-ename->vla-object blk))
                  )
        )
      )
    (mapcar '(lambda (x) (list (vla-get-tagstring x)
                               (vla-get-textstring x)
                               (vlax-vla-object->ename x)
                         )
             )
             (vlax-safearray->list lst)
    )
  )
)

zwx123

有请黄金长老帮忙啦！！！ ：）



难道没有人愿意帮忙？！  ：（

阿土

本身不是有属性提取的且可以导入电子表格的吗？为什么还要做程序呢？

雪山飞狐(lzh)

由于你没有提供块名，所以程序要求手动输入
先打开Excel再运行
Sub Test()
On Error Resume Next

    Dim ss As AcadSelectionSet
    Dim ft(1) As Integer, fd(1)
    Dim i As AcadBlockReference
    Dim objExcel As Object
    Dim pSheet As Object
    Dim pRange As Object
    Dim pNum As Integer

    Set objExcel = GetObject(, "Excel.Application")
    If Err Then MsgBox "请先打开Excel!": Exit Sub
    Set pSheet = objExcel.ActiveSheet
   
    ft(0) = 0: fd(0) = "Insert"
    ft(1) = 2: fd(1) = ThisDrawing.Utility.GetString(True, vbCr & "请输入块名：")
    ThisDrawing.SelectionSets("*TlsTest*").Delete
    Set ss = ThisDrawing.SelectionSets.Add("*TlsTest*")
    ss.Select acSelectionSetAll, , , ft, fd

    Set pRange = pSheet.Range("A1"): pRange.Value = "设备名称"
    Set pRange = pSheet.Range("B1"): pRange.Value = "规格型号"
    Set pRange = pSheet.Range("C1"): pRange.Value = "使用位置"
    Set pRange = pSheet.Range("D1"): pRange.Value = "备注"

    pNum = 2
   
    For Each i In ss
   
        a = i.GetAttributes
        Set pRange = pSheet.Range("A" & pNum): pRange.Value = a(0).TextString
        Set pRange = pSheet.Range("B" & pNum): pRange.Value = a(1).TextString
        Set pRange = pSheet.Range("C" & pNum): pRange.Value = a(2).TextString
        Set pRange = pSheet.Range("D" & pNum): pRange.Value = a(3).TextString
        pNum = pNum + 1
    Next i

End Sub