yang686526

程序问题顾老师?
www.dimcax.com
程序问题顾老师?
顾老师你好:
这程序试了好久,始终没能成功过,实在查不出哪有问题
,恳请顾老师出手帮忙解惑,铭心感激!
;;;添加普通文字到图块成为属性
;;;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 "y n")
(if (null (setq yn
(getkword "\n erase the attached texts [y/n] :")
)
)
(setq yn "y")
)
(vlobj-attach-attrib blk txt (equal yn "y"))
)
)
)
;;;blk--文字属性块图元名(car(entsel))
;;;atx--单行文字，注意是单行文字不是多行文字(car(entsel))，只是搂主说的pickset多选不会用
;;;erase--为空nil时保留原文字，否则删除
;;;代码:
(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 "aeh")
(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
)

顶一下,
程序问题请教顾老师
,若有高手知道原因
,也欢迎指导一下,谢谢!

把程序改了一下如下:
(defun c:addatt (/ blk txt yn)
(setq blk (entsel "\n 选择块 :") blk (car blk) en (entget blk))
(princ "\n 请选择文字到文字属性块去")
(setq txt (ssget '((0 . "text"))))
(if (and (= (cdr (assoc 0 en)) "insert")
(null (redraw blk 3))
)
(progn
(initget "y n")
(setq yn (getkword "\n erase the attached texts [y/n] :"))
(if (null yn)
(setq yn "y")
)
(vlobj-attach-attrib blk txt (equal yn "y"))
)
)
)
(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 "aeh")(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))))
)
)
)
)
))
gbg

顾老师你好:
程序下载后测试...
有问题...
我在autocad 2008下,点选文字实体无法顺利添加至图块内当属性.
有劳顾老师在调整一下,谢谢!
附注:被添加属性的图块,可为一般图块或带属性的图块.

用addatt把文字加到块去你的这个块是有属性了,你可用attlib这个程序去看和改变这个文字.
(defun c:addatt (/ blk txt yn)
(setq blk (entsel "\n 选择块 :") blk (car blk) en (entget blk))
(princ "\n 请选择文字到文字属性块去")
(setq txt (ssget '((0 . "text"))))
(if (and (= (cdr (assoc 0 en)) "insert")
(null (redraw blk 3))
)
(progn
(initget "y n")
(setq yn (getkword "\n erase the attached texts [y/n] :"))
(if (null yn)
(setq yn "y")
)
(vlobj-attach-attrib blk txt (equal yn "y"))
)
)
)
(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 "aeh")(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))))
)
)
)
)
))
(defun c:attlib ()
(prompt "带属性块:")
(setq en (car (entsel)) ed (entget en) )
(setq e1 (entnext en))
(setq ed (entget e1) txt (cdr (assoc 1 ed)))
(prompt (strcat "文字为本" txt))(terpri)
(setq a (getstring "是否要改文字(y) n"))
(if (= a "")(setq a "y"))
(if (= a "y")
(progn
(setq b (getstring "输入文字:"))
(setq ed (subst (cons 1 b) (assoc 1 ed) ed))
(setq ed (subst (cons 2 b) (assoc 2 ed) ed))
(entmod ed)
(entupd e1)
))
)
gbg

顾老师你好:
程序测试ok.非常感谢你.
有一个问提请教.
建一个"qq"图块及建一个"123"文字,
用addatt把文字加到图块去,
当"123"被删除时,
用attlib这个程序就抓不到资料"123",
也就是说"qq"图块及"123"文字必须同时存在同一张图内,
这样相当不方便,
可否改成加入的属性图块,
可被指令: _attedit编辑.