添加普通文字到图块成为属性

mmmmmm · 发表于 2007-2-2 23:34:00

函数共三个变量：
1：图块实体[ENAME]
2：文本实体[ENANE/单个 PICKSET/多个]
3：转换成属性后是否删除文本实体[T/NIL]

返回值：新生成的图块名[ENAME]

(Defun vlobj-attach-attrib (blk atx erase / att bbb nxx tmp rtn)
(setq bbb blk
blk (entget bbb)
)
(if (not (assoc 66 blk))
(setq blk (append blk (list (cons 66 1))))
)
(setq nxx (list blk))
(if (and (entnext bbb)
(= (cdr (assoc 0 (entget (entnext bbb)))) "ATTRIB")
)
(while
(/= (cdr (assoc 0 (entget (setq bbb (entnext bbb)))))
"SEQEND"
)
(setq nxx (cons (entget bbb) nxx))
)
)
(if (= (type atx) 'ename)
(setq atx (ssadd atx))
)
(if (and (= (type atx) 'pickset)
(setq bbb -1)
)
(progn
(repeat (sslength atx)
(if (and (setq att (ssname atx (setq bbb (1+ bbb))))
(setq tmp (cdr (assoc 1 (entget att)))
(setq tmp (list
(cons 0 "ATTRIB")
(cons 100 "AcDbEntity")
(cons 100 "AcDbText")
(cons 100 "AcDbAttribute")
(cons 1 tmp)
(cons 2 (substr tmp 1 10)) ;防止TAG太长
(cons 6 "ByBlock")
(cons 7 "STANDARD")
(cons 8 "0")
(list 10 0.0 0.0 0.0)
(list 11 0.0 0.0 0.0)
(cons 40 1.0)
(cons 41 1.0)
(cons 50 0.0)
(cons 51 0.0)
(cons 62 256)
(cons 70 0)
(cons 72 0)
(cons 73 0)
)
)
)
(progn
(foreach bbb '(7 8 10 11 40 41 50 51 72 73)
(setq
tmp (subst (cons bbb (cdr (assoc bbb (entget att))))
(assoc bbb tmp)
tmp
)
)
)
(setq nxx (cons tmp nxx))
)
)
)
(setq nxx (cons (list (cons 0 "SEQEND")
(cons 100 "AcDbEntity")
(cons 8 (cdr (assoc 8 blk)))
)
nxx
)
)
(mapcar 'entmake (reverse nxx))
(setq rtn (entlast))
(if (and erase
(setq bbb -1)
(entdel (cdr (assoc -1 blk)))
)
(repeat (sslength atx)
(entdel (ssname atx (setq bbb (1+ bbb))))
)
)
)
)
rtn
)
Simple VL command
;;;No error check, ugly codes only, not fully tested
(Defun c:addatt (/ blk txt yn)
(if
(and (setq blk (entsel "\n Please pick the block :"))
(setq blk (Car blk))
(= (cdr (assoc 0 (entget blk))) "INSERT")
(null (redraw blk 3))
(princ
"\n Please select text to be attached as attributes :"
)
(setq txt (ssget '((0 . "text"))))
)
(progn
(initget "Yen No")
(if (null (setq yn
(getkword "\n Erase the attached texts [Yes/No] :")
)
)
(setq yn "Yes")
)
(vlobj-attach-attrib blk txt (equal yn "Yes"))
)
)
)

(Defun vlobj-attach-attrib (blk atx erase / att bbb nxx tmp rtn)
  (setq  bbb blk
  blk (entget bbb)
  )
  (if (not (assoc 66 blk))
    (setq blk (append blk (list (cons 66 1))))
  )
  (setq nxx (list blk))
  (if (and (entnext bbb)
     (= (cdr (assoc 0 (entget (entnext bbb)))) "ATTRIB")
      )
    (while
      (/= (cdr (assoc 0 (entget (setq bbb (entnext bbb)))))
    "SEQEND"
      )
       (setq nxx (cons (entget bbb) nxx))
    )
  )
  (if (= (type atx) 'ename)
    (setq atx (ssadd atx))
  )
  (if (and (= (type atx) 'pickset)
     (setq bbb -1)
      )
    (progn      
      (repeat (sslength atx)
  (if (and (setq att (ssname atx (setq bbb (1+ bbb))))
     (setq tmp (cdr (assoc 1 (entget att)))  
     (setq tmp (list
           (cons 0 "ATTRIB")
           (cons 100 "AcDbEntity")
           (cons 100 "AcDbText")
           (cons 100 "AcDbAttribute")
           (cons 1 tmp)
           (cons 2 (substr tmp 1 10)) ;防止TAG太长
           (cons 6 "ByBlock")
           (cons 7 "STANDARD")
           (cons 8 "0")
           (list 10 0.0 0.0 0.0)
           (list 11 0.0 0.0 0.0)
           (cons 40 1.0)
           (cons 41 1.0)
           (cons 50 0.0)
           (cons 51 0.0)
           (cons 62 256)
           (cons 70 0)
           (cons 72 0)
           (cons 73 0)
         )
     )
      )
    (progn
      (foreach bbb '(7 8 10 11 40 41 50 51 72 73)
        (setq
    tmp (subst (cons bbb (cdr (assoc bbb (entget att))))
         (assoc bbb tmp)
         tmp
        )
        )
      )
      (setq nxx (cons tmp nxx))
    )
  )
      )
      (setq nxx  (cons (list (cons 0 "SEQEND")
          (cons 100 "AcDbEntity")
          (cons 8 (cdr (assoc 8 blk)))
          )
          nxx
    )
      )
      (mapcar 'entmake (reverse nxx))
      (setq rtn (entlast))
      (if (and erase
         (setq bbb -1)
         (entdel (cdr (assoc -1 blk)))
    )
  (repeat  (sslength atx)
    (entdel (ssname atx (setq bbb (1+ bbb))))
  )
      )
    )
  )
  rtn
)

Simple VL command
;;;No error check, ugly codes only, not fully tested
(Defun c:addatt  (/ blk txt yn)
  (if
    (and (setq blk (entsel "\n Please pick the block :"))
   (setq blk (Car blk))
   (= (cdr (assoc 0 (entget blk))) "INSERT")
                      (null (redraw blk 3))
   (princ
     "\n Please select text to be attached as attributes :"
   )
   (setq txt (ssget '((0 . "text"))))
    )
     (progn
       (initget "Yen No")
       (if (null (setq yn
      (getkword "\n Erase the attached texts [Yes/No] :")
     )
     )
   (setq yn "Yes")
       )
       (vlobj-attach-attrib blk txt (equal yn "Yes"))
     )
  )
)

yk1216 · 发表于 2024-5-21 09:17:07

参考学习下谢谢分享

Flynn_n · 发表于 2019-6-8 10:13:08

参考学习一下!

ygrzz · 发表于 2007-2-2 23:45:00

顶一个~~`

caoyin · 发表于 2007-2-3 13:48:00

(if (and (setq att (ssname atx (setq bbb (1+ bbb))))
(setq tmp (cdr (assoc 1 (entget att)));;;;;;;;这个地方少个闭括号

龙龙仔 · 发表于 2007-2-5 07:51:00

;;很有趣的結構--是圖塊參考帶屬性,非改變原圖塊為屬性圖塊
;;即相同的圖塊名稱,但有的帶屬性,有的卻沒有屬性

狂刀无痕 · 发表于 2007-2-5 12:06:00

这个问题以前在xdcad讨论过

属性是寄生虫。可以在树木种下去的时候有，也可以在种下去以后才有。有了还可以杀虫。

mccad · 发表于 2007-2-5 13:53:00

属性不属于块中的一个图元。而是附加上去的一些信息。所以属性的特性都可以单独操作，包括调整字体、对齐方式、修改内容。

呵呵，而单独添加以前倒一直都没有试过。

狂刀无痕 · 发表于 2007-2-5 15:03:00

做这个要用autolisp，好像vlisp做不来的

yoyoho · 发表于 2008-12-22 11:48:00

添加普通文字到图块成为属性

,有人使用过吗?
我在CAD2008下无法正常运行,不知什缘故?

XIAOFEILONG · 发表于 2008-12-22 19:42:00

请问:这个程序一般用在什么情况下?

我一时间都想不出哪些地方用这个程序比较有用?

xiaxiang · 发表于 2011-12-27 14:37:25

好程序，顶起，对我很有用处的

账号		自动登录	找回密码
密码			注册

添加普通文字到图块成为属性

评分