[求助]打碎块保留属性值程序的问题
程序是写出来了，可在运行过程中出现不少问题首先是文字的对齐方式，块属性里为中上，而写出的文字居中，这样就导致打碎后出现版面非常乱。
再就是删除ATTDEF过程也不太正常
请高人修改，谢谢！
;打碎块后保留其属性值
;思路：根据ATTRIB写TEXT，打碎块，删除ATTDEF
;参考http://www.mjtd.com/Codes/ArticleShow.asp?ArticleID=1190
(defun c:def (/ tc ss ent1 newtxt )
(setq tc (getvar "clayer"))
(prompt "\n请选择需要被打碎的块")
(setq ss (ssget '((0 . "INSERT"))))
(repeat (setq n (sslength ss))
(setq ent1 (entget (ssname ss (setq n (1- n)))))
(setvar "clayer" (get 8 ent1))
(while (/= (get 0 (setq ent1 (entget (entnext (get -1 ent1))))) "SEQEND")
(if (= (get 0 ent1) "ATTRIB")
(progn
(setq newtxt '((0 . "TEXT")))
(setq lst '(67 410 10 40 1 50 41 51 7 71 72 11 210 73))
(foreach xh lst
(setq dd (assoc xh ent1))
(if (/= dd nil)
(setq newtxt (append newtxt (list (assoc xh ent1))))
)
)
(entmake newtxt)
);progn
);if
);while
);repeat
(command "explode" ss)
(setq ss (ssget "_P" '((0 . "ATTDEF"))))
(command "erase" ss "")
(setvar "clayer" tc)
(princ)
) 附图和自定义的get
(defun get (aaaaa bbbbb /)
(cdr (assoc aaaaa bbbbb))
)
<p>前辈高人们帮帮忙呀！</p><p></p> (defun blkexp(blkref / adwg owner lst attrs atttextstr tmptext eblks )
;首先把其中的可见的属性给分解成文字,然后炸开,然后删除获得的属性,并且重复运行,以便完全炸开镶嵌块--
(setq adwg(vlax-get (vlax-get-acad-object) 'Activedocument)
owner(vlax-get blkref 'ownerid)
owner(vlax-invoke adwg 'ObjectIDToObject owner)
lst '( "Alignment" "backward" "color" "layer" "linetypescale" "linetype" "lineweight"
"obliqueangle" "Rotation" "ScaleFactor" "StyleName" "TextAlignmentPoint" "Thickness" "upsidedown"))
(if (eq (vlax-get blkref 'hasattributes) -1)
(progn
(setq attrs(vlax-invoke blkref 'getattributes))
(mapcar '(lambda(x)(if (and (not (eq -1 (vlax-get x 'invisible)));可见属性
(not (eq "" (setq atttextstr(vlax-get x 'textstring)))));属性值非""
(progn
(setq tmptext(vlax-invoke owner 'AddText atttextstr (vlax-get x 'insertionpoint)
(vlax-get x 'height)))
(mapcar '(lambda(y)(setq y(read y))(vlax-put tmptext y (vlax-get x y))) lst)
)
))attrs)
)
)
;上面把属性改成了文字,下面就是炸开块了~~~~~
(setq eblks(vlax-invoke blkref 'explode))
(mapcar '(lambda(x)
(if (eq "AcDbAttributeDefinition" (vlax-get x 'objectname))
(vlax-invoke x 'delete);属性删除--
(progn
(if (eq "AcDbBlockReference" (vlax-get x 'objectname));是块,则继续炸开~~~
(blkexp x)
)
)
)
) eblks)
(vlax-invoke blkref 'delete)
(princ)
)
;;在不爆開塊下把屬性值提出
;;BY LUCAS
(defun C:DEF (/ DD ENT ENT1 LST N NEWTXT SS TC)
(vl-load-com)
(setq TC (getvar "clayer"))
(prompt "\n請選擇屬性圖塊")
(if (setq SS (ssget '((0 . "INSERT") (66 . 1))))
(repeat (setq N (sslength SS))
(setq ENT1 (entget (ssname SS (setq N (1- N)))))
(setvar "clayer" (GET 8 ENT1))
(while
(/= (GET 0
(setq ENT1 (entget (setq ENT (entnext (GET -1 ENT1)))))
)
"SEQEND"
)
(if (= (GET 0 ENT1) "ATTRIB")
(progn
(setq NEWTXT '((0 . "TEXT")))
(setq LST '(67 410 10 40 1 50 41 51 7 71 72 11 210))
(foreach XH LST
(setq DD (assoc XH ENT1))
(if (/= DD NIL)
(setq NEWTXT (append NEWTXT (list (assoc XH ENT1))))
)
)
(setq
NEWTXT (append NEWTXT
(list (cons 73 (cdr (assoc 74 ENT1))))
)
)
(entmake NEWTXT)
(vla-delete (vlax-ename->vla-object ENT))
)
)
)
)
)
(setvar "clayer" TC)
(princ)
)
(defun GET (AAAAA BBBBB /)
(cdr (assoc AAAAA BBBBB))
)
<p>感谢前辈们的支持。</p><p>4楼的大部分为vlax函数，我这部分实在没有学会，但我把程序记下来了，供以后参考。</p><p>5楼的程序非常实用，对我错误的程序稍做改动，便十分完美了。</p><p>再次感谢龙龙仔！</p> LUCAS 出手就是不同凡响... 请问这个程序应该怎么运行呢，我保存成lisp文件后运行def提示语法错误是怎么回事？ 众里寻他千百度
页:
[1]