[求助]打碎块保留属性值程序的问题

dinosaurhxe

程序是写出来了，可在运行过程中出现不少问题
首先是文字的对齐方式，块属性里为中上，而写出的文字居中，这样就导致打碎后出现版面非常乱。
再就是删除ATTDEF过程也不太正常
请高人修改，谢谢！

2. ;打碎块后保留其属性值
3. ;思路：根据ATTRIB写TEXT，打碎块，删除ATTDEF
4. ;参考http://www.mjtd.com/Codes/ArticleShow.asp?ArticleID=1190
5. (defun c:def (/ tc ss ent1 newtxt )
6. (setq tc (getvar "clayer"))
7. (prompt "\n请选择需要被打碎的块")
8. (setq ss (ssget '((0 . "INSERT"))))
9. (repeat (setq n (sslength ss))
10.   (setq ent1 (entget (ssname ss (setq n (1- n)))))
11.   (setvar "clayer" (get 8 ent1))
12.   (while (/= (get 0 (setq ent1 (entget (entnext (get -1 ent1))))) "SEQEND")
13.    (if (= (get 0 ent1) "ATTRIB")
14.     (progn
15.      (setq newtxt '((0 . "TEXT")))
16.      (setq lst '(67 410 10 40 1 50 41 51 7 71 72 11 210 73))
17.      (foreach xh lst
18.       (setq dd (assoc xh ent1))
19.       (if (/= dd nil)
20.        (setq newtxt (append newtxt (list (assoc xh ent1))))
21.       )
22.      )
23.      (entmake newtxt)
24.     );progn
25.    );if
26.   );while
27. );repeat
28. (command "explode" ss)
29. (setq ss (ssget "_P" '((0 . "ATTDEF"))))
30. (command "erase" ss "")
31. (setvar "clayer" tc)
32. (princ)
33. )

;打碎块后保留其属性值 ;思路：根据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) )

dinosaurhxe

附图和自定义的get

2. (defun get (aaaaa bbbbb /)
3.   (cdr (assoc aaaaa bbbbb))
4. )

(defun get (aaaaa bbbbb /)   (cdr (assoc aaaaa bbbbb)) )

dinosaurhxe

前辈高人们帮帮忙呀！

danxingpen

2. (defun blkexp(blkref / adwg owner lst attrs atttextstr tmptext eblks )
3.   ;首先把其中的可见的属性给分解成文字,然后炸开,然后删除获得的属性,并且重复运行,以便完全炸开镶嵌块--
4.   (setq adwg(vlax-get (vlax-get-acad-object) 'Activedocument)
5.     owner(vlax-get blkref 'ownerid)
6.     owner(vlax-invoke adwg 'ObjectIDToObject owner)
7.     lst '( "Alignment" "backward" "color"  "layer"  "linetypescale" "linetype"  "lineweight"
8.           "obliqueangle"  "Rotation" "ScaleFactor" "StyleName" "TextAlignmentPoint" "Thickness" "upsidedown"))
9.   (if (eq (vlax-get blkref 'hasattributes) -1)
10.     (progn
11.       (setq attrs(vlax-invoke blkref 'getattributes))
12.       (mapcar '(lambda(x)(if (and (not (eq -1 (vlax-get x 'invisible)));可见属性
13.                   (not (eq "" (setq atttextstr(vlax-get x 'textstring)))));属性值非""
14.                (progn
15.                  (setq tmptext(vlax-invoke owner 'AddText atttextstr (vlax-get x 'insertionpoint)
16.                                                              (vlax-get x 'height)))
17.                  (mapcar '(lambda(y)(setq y(read y))(vlax-put tmptext y (vlax-get x y))) lst)
18.                )
19.                ))attrs)
20.     )
21.   )
22.   ;上面把属性改成了文字,下面就是炸开块了~~~~~
23.   (setq eblks(vlax-invoke blkref 'explode))
24.   (mapcar '(lambda(x)
25.          (if (eq "AcDbAttributeDefinition" (vlax-get x 'objectname))
26.            (vlax-invoke x 'delete);属性删除--
27.            (progn
28.          (if (eq "AcDbBlockReference" (vlax-get x 'objectname));是块,则继续炸开~~~
29.            (blkexp x)
30.          )
31.            )
32.          )
33.          ) eblks)
34.   (vlax-invoke blkref 'delete)
35.   (princ)
36. )

(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) )

龙龙仔

3. ;;在不爆開塊下把屬性值提出
4. ;;BY LUCAS
5. (defun C:DEF (/ DD ENT ENT1 LST N NEWTXT SS TC)
6.   (vl-load-com)
7.   (setq TC (getvar "clayer"))
8.   (prompt "\n請選擇屬性圖塊")
9.   (if (setq SS (ssget '((0 . "INSERT") (66 . 1))))
10.     (repeat (setq N (sslength SS))
11.       (setq ENT1 (entget (ssname SS (setq N (1- N)))))
12.       (setvar "clayer" (GET 8 ENT1))
13.       (while
14. (/= (GET 0
15.    (setq ENT1 (entget (setq ENT (entnext (GET -1 ENT1)))))
16.      )
17.      "SEQEND"
18. )
19.   (if (= (GET 0 ENT1) "ATTRIB")
20.     (progn
21.       (setq NEWTXT '((0 . "TEXT")))
22.       (setq LST '(67 410 10 40 1 50 41 51 7 71 72 11 210))
23.       (foreach XH LST
24.         (setq DD (assoc XH ENT1))
25.         (if (/= DD NIL)
26.    (setq NEWTXT (append NEWTXT (list (assoc XH ENT1))))
27.         )
28.       )
29.       (setq
30.         NEWTXT (append NEWTXT
31.          (list (cons 73 (cdr (assoc 74 ENT1))))
32.         )
33.       )
34.       (entmake NEWTXT)
35.       (vla-delete (vlax-ename->vla-object ENT))
36.     )
37.   )
38.       )
39.     )
40.   )
41.   (setvar "clayer" TC)
42.   (princ)
43. )
44. (defun GET (AAAAA BBBBB /)
45.   (cdr (assoc AAAAA BBBBB))
46. )

;;在不爆開塊下把屬性值提出 ;;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)) )

dinosaurhxe

感谢前辈们的支持。

4楼的大部分为vlax函数，我这部分实在没有学会，但我把程序记下来了，供以后参考。

5楼的程序非常实用，对我错误的程序稍做改动，便十分完美了。

再次感谢龙龙仔！

etom999

LUCAS 出手就是不同凡响...

dasaxi

请问这个程序应该怎么运行呢，我保存成lisp文件后运行def提示语法错误是怎么回事？

zwf100

众里寻他千百度