仿Presscad 多段线方向检查

易云网络

[ 本帖最后由 易云网络 于 2015-5-17 10:49 编辑 ]\n\n[ 本帖最后由 易云网络 于 2015-5-17 10:42 编辑 ]\n\n在这里有几个月了，收集了些函数，拼凑了段效率只有Presscad40%左右的源码，
现在发出来希望有朋友用得着，
顺便希望哪位大佬能提高一下效率，

1. (defun C:sed()
   
2.   
   
3.   (defun sys_var ()
   
4.     (setq e_lst (mapcar (function (lambda (n) (list 'setvar n (getvar n))))
   
5.         '("cecolor" "clayer" "LUPrec" "autosnap" "osmode" "aperture" "hpspace" "hpassoc" "mirrtext" "auprec" "luprec" "dimzin" )))
   
6.     (defun *error* (msg)  (mapcar 'eval e_lst)))
   
7.   
   
8.   
   
9.   (defun dxf (ent i)
   
10.     (cond ((= (type ent) 'ename)
    
11.         (cdr (assoc i (entget ent '("*"))))
    
12.       )
    
13.       ((= (type ent) 'list)
    
14.         (cdr (assoc i ent))
    
15.       )
    
16.     )
    
17.   )
    
18.   
    
19.   (defun ang2rad (ang)
    
20.     (* pi (/ ang 180.))
    
21.   )
    
22.   
    
23.   ;返回多义线的各顶点By ;By 无痕
    
24.   (defun get-pl-pt (e / i v lst)
    
25.     (setq i -1)
    
26.     (while (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
    
27.       (setq lst (cons v lst))
    
28.     )
    
29.     (reverse lst)
    
30.   )
    
31.   
    
32.   ;;8 中点+总长度+角度画直线
    
33.   (defun Plline (pt Long ang)
    
34.     (setq pl1   (polar pt (ang2rad ang) (* 0.5 long) ))
    
35.     (setq pl2   (polar pt (+ pi (ang2rad ang)) (* 0.5 long) ))
    
36.     (entmake (list (cons 0 "LINE") (cons 10 pl1) (cons 11 pl2)))
    
37.   )
    
38.   
    
39.   
    
40.   (defun sed-error (msg) (mapcar 'eval e_lst)
    
41.     (setq ssb (ssadd))
    
42.     (while    (entnext lastty)  
    
43.       (ssadd  (entnext lastty) ssb)
    
44.       (setq lastty (entnext lastty))
    
45.     )
    
46.     (command "erase" ssb "")
    
47.     (princ)
    
48.   )
    
49.   
    
50.   (defun Ptline3j (p1 p2)
    
51.     (setq ang (angle p2 p1))
    
52.     ;(entmake (list (cons 0 "LINE") (cons 10 p2) (cons 11 (polar p2 ang tt))))
    
53.     (entmake (list (cons 0 "LINE") (cons 10 p2) (cons 11 (polar p2 (+ 0.5 ang) tt))))
    
54.     (entmake (list (cons 0 "LINE") (cons 10 p2) (cons 11 (polar p2 (- ang 0.5 ) tt))))
    
55.   )
    
56.   
    
57.   (setvar "cmdecho" 0)
    
58.   (command ".undo" "be")
    
59.   (sys_var)
    
60.   
    
61.   (vl-load-com)
    
62.   
    
63.   (setq   
    
64.     *error*   sed-error
    
65.     ptctr (getvar "viewctr") ; 视口中心点
    
66.     vph   (getvar "viewsize") ; 视口高度(以画图单位计算)
    
67.     vps   (getvar "screensize") ; 视口宽度和高度(以像素为单位)
    
68.     ratio (/ (car vps) (cadr vps))
    
69.     vpw   (* ratio vph)
    
70.     ptlb  (list (- (car ptctr) (/ vpw 2))  (- (cadr ptctr) (/ vph 2)) )  ; 左下角点
    
71.     ptrt  (list (+ (car ptctr) (/ vpw 2))  (+ (cadr ptctr) (/ vph 2)) )  ; 右上角点
    
72.     tt   (* 0.012 (distance ptlb ptrt))
    
73.   )
    
74.   
    
75.   (setq ss (ssget "x" '((0 . "LWPOLYLINE"))))
    
76.   ;(setq ss (ssget '((0 . "*POLYLINE"))))
    
77.   (setq lastty (entlast));将最后一个图元记录在lastty中
    
78.   (if (/= ss nil)
    
79.     (progn
    
80.       (setq   n -1)
    
81.       (repeat (sslength ss)
    
82.         (setq ent (ssname ss (setq n (1+ n))))
    
83.         (setq cx1 (get-pl-pt ent))
    
84.         (setq p11 (car cx1))
    
85.         (repeat  (1- (dxf  ent 90))
    
86.           (setq p1 (car cx1)
    
87.             　　p2 (cadr cx1)
    
88.             　　cx1 (cdr cx1)
    
89.           )
    
90.           (Ptline3j p1 p2)
    
91.         )
    
92.         (setq p1 (car cx1)
    
93.           　　p2 (cadr cx1))
    
94.         (if (=  p2 nil)
    
95.           (progn
    
96.             (entmake    (list '(0 . "CIRCLE") (cons 10 p11) (cons 40 tt)))
    
97.             (Plline p11 (+ tt tt) 45)   
    
98.             (Plline p11 (+ tt tt) -45)   
    
99.           )        
    
100.           (Ptline3j p1 p2)))
     
101.       
     
102.       (getpoint "\n---- 方向(断点)检查(ShowDir) 按按任意鼠标键:结束：")
     
103.       
     
104.       ;sa是COPY前的选择集，sb是COPY后新生成的选择集
     
105.       
     
106.       (setq ssb (ssadd))
     
107.       (while    (entnext lastty)  
     
108.         (ssadd  (entnext lastty) ssb)
     
109.         (setq lastty (entnext lastty))
     
110.       )
     
111.       (command "erase" ssb "")
     
112.       (princ)
     
113.       
     
114. )))

(defun C:sed()<br />   <br />   (defun sys_var ()<br />     (setq e_lst (mapcar (function (lambda (n) (list 'setvar n (getvar n)))) <br />         '("cecolor" "clayer" "LUPrec" "autosnap" "osmode" "aperture" "hpspace" "hpassoc" "mirrtext" "auprec" "luprec" "dimzin" )))<br />     (defun *error* (msg)  (mapcar 'eval e_lst)))<br />   <br />   <br />   (defun dxf (ent i)<br />     (cond ((= (type ent) 'ename)<br />         (cdr (assoc i (entget ent '("*"))))<br />       )<br />       ((= (type ent) 'list)<br />         (cdr (assoc i ent))<br />       )<br />     )<br />   )<br />   <br />   (defun ang2rad (ang) <br />     (* pi (/ ang 180.))<br />   )<br />   <br />   ;返回多义线的各顶点By ;By 无痕<br />   (defun get-pl-pt (e / i v lst)<br />     (setq i -1)<br />     (while (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))<br />       (setq lst (cons v lst))<br />     )<br />     (reverse lst)<br />   )<br />   <br />   ;;8 中点+总长度+角度画直线<br />   (defun Plline (pt Long ang)<br />     (setq pl1   (polar pt (ang2rad ang) (* 0.5 long) ))<br />     (setq pl2   (polar pt (+ pi (ang2rad ang)) (* 0.5 long) ))<br />     (entmake (list (cons 0 "LINE") (cons 10 pl1) (cons 11 pl2)))<br />   )<br />   <br />   <br />   (defun sed-error (msg) (mapcar 'eval e_lst)<br />     (setq ssb (ssadd))<br />     (while    (entnext lastty)  <br />       (ssadd  (entnext lastty) ssb)<br />       (setq lastty (entnext lastty))<br />     )<br />     (command "erase" ssb "")<br />     (princ)<br />   )<br />   <br />   (defun Ptline3j (p1 p2)<br />     (setq ang (angle p2 p1))<br />     ;(entmake (list (cons 0 "LINE") (cons 10 p2) (cons 11 (polar p2 ang tt))))<br />     (entmake (list (cons 0 "LINE") (cons 10 p2) (cons 11 (polar p2 (+ 0.5 ang) tt))))<br />     (entmake (list (cons 0 "LINE") (cons 10 p2) (cons 11 (polar p2 (- ang 0.5 ) tt))))<br />   )<br />   <br />   (setvar "cmdecho" 0)<br />   (command ".undo" "be")<br />   (sys_var)<br />   <br />   (vl-load-com)<br />   <br />   (setq    <br />     *error*   sed-error <br />     ptctr (getvar "viewctr") ; 视口中心点<br />     vph   (getvar "viewsize") ; 视口高度(以画图单位计算)<br />     vps   (getvar "screensize") ; 视口宽度和高度(以像素为单位)<br />     ratio (/ (car vps) (cadr vps))<br />     vpw   (* ratio vph)<br />     ptlb  (list (- (car ptctr) (/ vpw 2))  (- (cadr ptctr) (/ vph 2)) )  ; 左下角点<br />     ptrt  (list (+ (car ptctr) (/ vpw 2))  (+ (cadr ptctr) (/ vph 2)) )  ; 右上角点 <br />     tt   (* 0.012 (distance ptlb ptrt))<br />   )<br />   <br />   (setq ss (ssget "x" '((0 . "LWPOLYLINE"))))<br />   ;(setq ss (ssget '((0 . "*POLYLINE"))))<br />   (setq lastty (entlast));将最后一个图元记录在lastty中<br />   (if (/= ss nil) <br />     (progn<br />       (setq   n -1)<br />       (repeat (sslength ss)<br />         (setq ent (ssname ss (setq n (1+ n))))<br />         (setq cx1 (get-pl-pt ent))<br />         (setq p11 (car cx1))<br />         (repeat  (1- (dxf  ent 90))<br />           (setq p1 (car cx1) <br />             　　p2 (cadr cx1) <br />             　　cx1 (cdr cx1)<br />           )<br />           (Ptline3j p1 p2)<br />         )<br />         (setq p1 (car cx1) <br />           　　p2 (cadr cx1))<br />         (if (=  p2 nil)<br />           (progn <br />             (entmake    (list '(0 . "CIRCLE") (cons 10 p11) (cons 40 tt)))<br />             (Plline p11 (+ tt tt) 45)    <br />             (Plline p11 (+ tt tt) -45)    <br />           )        <br />           (Ptline3j p1 p2)))<br />       <br />       (getpoint "\n---- 方向(断点)检查(ShowDir) 按按任意鼠标键:结束：")<br />       <br />       ;sa是COPY前的选择集，sb是COPY后新生成的选择集<br />       <br />       (setq ssb (ssadd))<br />       (while    (entnext lastty)  <br />         (ssadd  (entnext lastty) ssb)<br />         (setq lastty (entnext lastty))<br />       )<br />       (command "erase" ssb "")<br />       (princ)<br />       <br /> )))

yoyoho

感谢 易云网络 分享程序!