[LISP程序]：多义线改厚度

梦断江南

由mf7000的发帖引申，参考：http://www.xdcad.net/forum/showt ... tid=49258#post49258
做了一个lsp,另一种写法。
增加 M-厚度反相/ <拉伸到指定点高度>，对多个不同z高度多义线拉伸厚度到同一高度有效（此时厚度不同）

2. 
   
3.   [FONT=courier new]
   
4. ;;plth多义线拉伸厚度v1.0-----------www.xdcad.net--dreamsky.lxx.梦断江南.2002.7
   
5. (defun c:plth ();( / ptz ss i pt1 pt2 thk ent i entl lpz lpth)
   
6.   (princ "\n plth多义线拉伸厚度v1.0------------www.xdcad.net--dreamsky.lxx.梦断江南.2002.7")
   
7.   (initget "  X Y Z D M " )
   
8.   (setq ptz (getstring "\n X-高度按两点x差值/Y/Z/D-距离定拉伸高度/M-厚度反相/<拉伸到指定点高度>:")
   
9.          ss (ssget '((0 . "*LINE,ARC,CIRCLE,ELLIPSE")))
   
10.          i 0)
    
11. (cond
    
12.    ((wcmatch ptz "[xXyYzZdD]")
    
13.     (setq pt1 (getpoint "\n第一点:")
    
14.           pt2 (getpoint pt1 "\n第二点:")
    
15.           thk (cond ((wcmatch ptz "[xX]")(- (car pt2)(car pt1)) )
    
16.                     ((wcmatch ptz "[yY]")(- (cadr pt2)(cadr pt1)) )
    
17.                     ((wcmatch ptz "[zZ]")(- (caddr pt2)(caddr pt1)) )
    
18.                     ((wcmatch ptz "[dD]")(distance pt1 pt2) )
    
19.               )
    
20.     );end setq
    
21.     (if thk (COMMAND "_.CHPROP" ss "" "T" thk ""))
    
22.    );end case1
    
23.   (T
    
24.    (if (= "" ptz) (setq ptz (caddr (getpoint "\n指定高度点:"))))
    
25.    (repeat (sslength ss)
    
26.     (setq ent (ssname ss i)
    
27.           i (1+ i)
    
28.           entl (entget ent)
    
29.           lpz (cdr (assoc 38 entl))
    
30.           lpth (cdr (assoc 39 entl)))
    
31.     (cond
    
32.       ((or (= "m" ptz)(= "M" ptz))(setq lpth (- 0 lpth)))
    
33.       (t (setq lpth (- ptz lpz)))
    
34.     );end cond
    
35.     (setq entl2 (subst (cons 39 lpth)(assoc 39 entl) entl))
    
36.     (entmod entl2)
    
37.    );end repeat
    
38.   );;end case2
    
39. );;end cond
    
40. (princ)
    
41. )
    
42.   [/FONT]
    

<br />   [FONT=courier new]<br /> ;;plth多义线拉伸厚度v1.0-----------www.xdcad.net--dreamsky.lxx.梦断江南.2002.7<br /> (defun c:plth ();( / ptz ss i pt1 pt2 thk ent i entl lpz lpth)<br />   (princ "\n plth多义线拉伸厚度v1.0------------www.xdcad.net--dreamsky.lxx.梦断江南.2002.7")<br />   (initget "  X Y Z D M " )<br />   (setq ptz (getstring "\n X-高度按两点x差值/Y/Z/D-距离定拉伸高度/M-厚度反相/<拉伸到指定点高度>:")<br />          ss (ssget '((0 . "*LINE,ARC,CIRCLE,ELLIPSE")))<br />          i 0)<br /> (cond<br />    ((wcmatch ptz "[xXyYzZdD]")<br />     (setq pt1 (getpoint "\n第一点:")<br />           pt2 (getpoint pt1 "\n第二点:")<br />           thk (cond ((wcmatch ptz "[xX]")(- (car pt2)(car pt1)) )<br />                     ((wcmatch ptz "[yY]")(- (cadr pt2)(cadr pt1)) )<br />                     ((wcmatch ptz "[zZ]")(- (caddr pt2)(caddr pt1)) )<br />                     ((wcmatch ptz "[dD]")(distance pt1 pt2) )<br />               )<br />     );end setq<br />     (if thk (COMMAND "_.CHPROP" ss "" "T" thk ""))<br />    );end case1<br />   (T<br />    (if (= "" ptz) (setq ptz (caddr (getpoint "\n指定高度点:"))))<br />    (repeat (sslength ss)<br />     (setq ent (ssname ss i)<br />           i (1+ i)<br />           entl (entget ent)<br />           lpz (cdr (assoc 38 entl))<br />           lpth (cdr (assoc 39 entl)))<br />     (cond <br />       ((or (= "m" ptz)(= "M" ptz))(setq lpth (- 0 lpth)))<br />       (t (setq lpth (- ptz lpz)))<br />     );end cond<br />     (setq entl2 (subst (cons 39 lpth)(assoc 39 entl) entl))<br />     (entmod entl2)<br />    );end repeat<br />   );;end case2<br /> );;end cond<br /> (princ)<br /> )<br />   [/FONT]<br />