[原创]：生成边界轮廓线程序，可以支持spline ellipse insert

lyy

2. [font=courier]
   
3. ;;边界轮廓线
   
4. (vl-load-com)
   
5. (defun c:yad_outline(/ viewpt maxmin spl2arc ss_add os cor qa ss n pt1 pt2 l_pt dis ent m)
   
6.   (defun viewpt(/ a b c d x)
   
7.     (setq b (getvar "viewsize") c (car (getvar "screensize")) d (cadr (getvar "screensize"))
   
8.           a (* b (/ c d)) x (setq x (getvar "viewctr")) x (trans x 1 2) c (list (- (car x)  (/ a 2.0)) (- (cadr x) (/ b 2.0)) 0.0)
   
9.           d (list (+ (car x) (/ a 2.0)) (+ (cadr x) (/ b 2.0)) 0.0) c (trans c 2 1) d (trans d 2 1)
   
10.     )
    
11.     (list c d)
    
12.   )
    
13.   (defun maxmin(lst / x n a b c d)
    
14.     (setq x (car lst) a (car x) b (cadr x) c (car x) d (cadr x) n 1)
    
15.     (repeat (max (- (length lst) 1) 0)
    
16.       (setq x (nth n lst) a (min a (car x)) b (min b (cadr x)) c (max c (car x)) d (max d (cadr x)))
    
17.       (setq n (1+ n))
    
18.     )
    
19.     (list (list a b) (list c d))
    
20.   )
    
21.   (defun spl2arc(ent / obj len num spt ept ss i pt1 pt2 pt3 s)
    
22.     (setq obj (vlax-ename->vla-object ent)
    
23.           len (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj))
    
24.           num (1+ (fix (/ len dis)))
    
25.           num (if (= num 1) 2 num)
    
26.           spt (vlax-curve-getStartPoint obj)
    
27.           ept (vlax-curve-getEndPoint obj)
    
28.     )
    
29.     (command "_.divide" ent (* 2 num))
    
30.     (setvar "cecolor" "1")
    
31.     (setq ss (ssget "_p"))
    
32.     (if (equal spt ept)
    
33.       (setq i 1)
    
34.       (setq i 0)
    
35.     )
    
36.     (setq pt3 spt)
    
37.     (setq s (ssadd))
    
38.     (repeat num
    
39.       (setq pt2 (cdr (assoc 10 (entget (ssname ss i)))))
    
40.       (if (/= num (/ (+ i 2) 2))
    
41.         (setq pt1 (cdr (assoc 10 (entget (ssname ss (1+ i))))))
    
42.         (setq pt1 ept)
    
43.       )
    
44.       (command "_.arc" pt3 pt2 pt1)
    
45.       (ssadd (entlast) s)
    
46.       (setq pt3 pt1)
    
47.       (setq i (+ 2 i))
    
48.     )
    
49.     (command "_.erase" ss ent "")
    
50.     (setvar "cecolor" "188")
    
51.     s
    
52.   )
    
53.   (defun ss_add(s1 s2 / n)
    
54.     (setq n -1)
    
55.     (repeat (sslength s1)
    
56.       (ssadd (ssname s1 (setq n (1+ n))) s2)
    
57.     )
    
58.     s2
    
59.   )
    
60.   (prompt "\n请选择要生成边界轮廓线的所有对象（图块轮廓要闭合）：")
    
61.   (if (setq ss (ssget '((0 . "line,arc,circle,*polyline,spline,ellipse,insert"))))
    
62.     (progn
    
63.       (command "_.undo" "_be")
    
64.       (setq os (getvar "osmode")
    
65.             cor (getvar "cecolor")
    
66.             qa (getvar "qaflags")
    
67.       )
    
68.       (setvar "osmode" 0)
    
69.       (setvar "cmdecho" 0)
    
70.       (setq n -1)
    
71.       (repeat (sslength ss)
    
72.         (vla-getboundingbox (vlax-ename->vla-object (ssname ss (setq n (1+ n)))) 'pt1 'pt2)
    
73.         (setq l_pt (append l_pt (list (vlax-safearray->list pt1) (vlax-safearray->list pt2))))
    
74.       )
    
75.       (setq l_pt (maxmin l_pt)
    
76.             pt1 (car l_pt)
    
77.             pt2 (cadr l_pt)
    
78.             dis (/ (distance pt1 pt2) 20)
    
79.             pt1 (polar pt1 (angle pt2 pt1) dis)
    
80.             pt2 (polar pt2 (angle pt1 pt2) dis)
    
81.       )
    
82.       (setq l_pt (maxmin (append (viewpt) (list pt1 pt2))))
    
83.       (command "_.zoom" "_w" (car l_pt) (cadr l_pt))
    
84.       (setvar "cecolor" "188")
    
85.       (command "_.rectang" pt1 pt2)
    
86.       (setq ent (entlast))
    
87.       (command "_.boundary" "_a" "_o" "_r" "_i" "_y" "_b" "_n" ent ss "" "" (polar pt1 (angle pt1 pt2) (/ dis 2)) "")
    
88.       (if (equal (entlast) ent)
    
89.         (progn
    
90.           (entdel ent)
    
91.           (prompt "\n没有边界轮廓线！")
    
92.         )
    
93.         (progn
    
94.           (entdel ent)
    
95.           (command "_.erase" (ssget "c" pt1 pt1 '((0 . "region") (62 . 188))) "")
    
96.           (setq m 0)
    
97.           (if (setq ss (ssget "x" '((0 . "region") (62 . 188))))
    
98.             (progn
    
99.               (command "_.union" ss "")
    
100.               (entmod (subst (cons 62 1) (cons 62 188) (entget (setq ent (entlast)))))
     
101.               (command "_.explode" ent)
     
102.               (setq ss (ssget "_p"))
     
103.               (if (= (cdr (assoc 0 (entget (ssname ss 0)))) "REGION")
     
104.                 (progn
     
105.                   (setvar "qaflags" 1)
     
106.                   (command "_.explode" ss "")
     
107.                   (setq ss (ssget "_p"))
     
108.                 )
     
109.               )
     
110.               (if (ssget "p" '((0 . "spline,ellipse")))
     
111.                 (progn
     
112.                   (setq dis (abs (if (setq dis (getreal "\n请输入样条曲线或椭圆的取样距离：<600>")) dis 600.0)))
     
113.                   (if (= dis 0.0) (setq dis 600.0))
     
114.                 )
     
115.               )
     
116.               (setq n -1)
     
117.               (repeat (sslength ss)
     
118.                 (setq ent (ssname ss (setq n (1+ n)))
     
119.                       name (cdr (assoc 0 (entget ent)))
     
120.                 )
     
121.                 (if (or (= name "SPLINE") (= name "ELLIPSE"))
     
122.                   (progn
     
123.                     (ssdel ent ss)
     
124.                     (setq ss (ss_add (spl2arc ent) ss))
     
125.                     (setq n (1- n))
     
126.                   )
     
127.                 )
     
128.               )
     
129.               (setq n -1)
     
130.               (while (setq ent (ssname ss (setq n (1+ n))))
     
131.                 (if (entget ent)
     
132.                   (progn
     
133.                     (command "_.pedit" ent "_y" "_j" ss "" "")
     
134.                     (setq m (1+ m))
     
135.                   )
     
136.                 )
     
137.               )
     
138.             )
     
139.           )
     
140.           (if (setq ss (ssget "x" '((0 . "*polyline") (62 . 188))))
     
141.             (progn
     
142.               (setq n -1)
     
143.               (repeat (sslength ss)
     
144.                 (entmod (subst (cons 62 1) (cons 62 188) (entget (ssname ss (setq n (1+ n))))))
     
145.               )
     
146.               (setq m (+ m (sslength ss)))
     
147.             )
     
148.           )
     
149.           (if (= m 0)
     
150.             (prompt "\n没有边界轮廓线！")
     
151.             (prompt (strcat "\n生成" (itoa m) "条边界轮廓线！"))
     
152.           )
     
153.         )
     
154.       )
     
155.       (setvar "osmode" os)
     
156.       (setvar "cecolor" cor)
     
157.       (setvar "qaflags" qa)
     
158.       (command "_.undo" "_e")
     
159.     )
     
160.   )
     
161.   (princ)
     
162. )
     
163. (prompt "\n***边界轮廓线yad_outline***  YAD建筑")
     
164. (princ)
     
165. [/font]

[font=courier]<br /> ;;边界轮廓线<br /> (vl-load-com)<br /> (defun c:yad_outline(/ viewpt maxmin spl2arc ss_add os cor qa ss n pt1 pt2 l_pt dis ent m)<br />   (defun viewpt(/ a b c d x)<br />     (setq b (getvar "viewsize") c (car (getvar "screensize")) d (cadr (getvar "screensize"))<br />           a (* b (/ c d)) x (setq x (getvar "viewctr")) x (trans x 1 2) c (list (- (car x)  (/ a 2.0)) (- (cadr x) (/ b 2.0)) 0.0)<br />           d (list (+ (car x) (/ a 2.0)) (+ (cadr x) (/ b 2.0)) 0.0) c (trans c 2 1) d (trans d 2 1)<br />     )<br />     (list c d)<br />   )<br />   (defun maxmin(lst / x n a b c d)<br />     (setq x (car lst) a (car x) b (cadr x) c (car x) d (cadr x) n 1)<br />     (repeat (max (- (length lst) 1) 0)<br />       (setq x (nth n lst) a (min a (car x)) b (min b (cadr x)) c (max c (car x)) d (max d (cadr x)))<br />       (setq n (1+ n))<br />     )<br />     (list (list a b) (list c d))<br />   )<br />   (defun spl2arc(ent / obj len num spt ept ss i pt1 pt2 pt3 s)<br />     (setq obj (vlax-ename->vla-object ent)<br />           len (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj))<br />           num (1+ (fix (/ len dis)))<br />           num (if (= num 1) 2 num)<br />           spt (vlax-curve-getStartPoint obj)<br />           ept (vlax-curve-getEndPoint obj)<br />     )<br />     (command "_.divide" ent (* 2 num))<br />     (setvar "cecolor" "1")<br />     (setq ss (ssget "_p"))<br />     (if (equal spt ept)<br />       (setq i 1)<br />       (setq i 0)<br />     )<br />     (setq pt3 spt)<br />     (setq s (ssadd))<br />     (repeat num<br />       (setq pt2 (cdr (assoc 10 (entget (ssname ss i)))))<br />       (if (/= num (/ (+ i 2) 2))<br />         (setq pt1 (cdr (assoc 10 (entget (ssname ss (1+ i))))))<br />         (setq pt1 ept)<br />       )<br />       (command "_.arc" pt3 pt2 pt1)<br />       (ssadd (entlast) s)<br />       (setq pt3 pt1)<br />       (setq i (+ 2 i))<br />     )<br />     (command "_.erase" ss ent "")<br />     (setvar "cecolor" "188")<br />     s<br />   )<br />   (defun ss_add(s1 s2 / n)<br />     (setq n -1)<br />     (repeat (sslength s1)<br />       (ssadd (ssname s1 (setq n (1+ n))) s2)<br />     )<br />     s2<br />   )<br />   (prompt "\n请选择要生成边界轮廓线的所有对象（图块轮廓要闭合）：")<br />   (if (setq ss (ssget '((0 . "line,arc,circle,*polyline,spline,ellipse,insert"))))<br />     (progn<br />       (command "_.undo" "_be")<br />       (setq os (getvar "osmode")<br />             cor (getvar "cecolor")<br />             qa (getvar "qaflags")<br />       )<br />       (setvar "osmode" 0)<br />       (setvar "cmdecho" 0)<br />       (setq n -1)<br />       (repeat (sslength ss)<br />         (vla-getboundingbox (vlax-ename->vla-object (ssname ss (setq n (1+ n)))) 'pt1 'pt2)<br />         (setq l_pt (append l_pt (list (vlax-safearray->list pt1) (vlax-safearray->list pt2))))<br />       )<br />       (setq l_pt (maxmin l_pt)<br />             pt1 (car l_pt)<br />             pt2 (cadr l_pt)<br />             dis (/ (distance pt1 pt2) 20)<br />             pt1 (polar pt1 (angle pt2 pt1) dis)<br />             pt2 (polar pt2 (angle pt1 pt2) dis)<br />       )<br />       (setq l_pt (maxmin (append (viewpt) (list pt1 pt2))))<br />       (command "_.zoom" "_w" (car l_pt) (cadr l_pt))<br />       (setvar "cecolor" "188")<br />       (command "_.rectang" pt1 pt2)<br />       (setq ent (entlast))<br />       (command "_.boundary" "_a" "_o" "_r" "_i" "_y" "_b" "_n" ent ss "" "" (polar pt1 (angle pt1 pt2) (/ dis 2)) "")<br />       (if (equal (entlast) ent)<br />         (progn<br />           (entdel ent)<br />           (prompt "\n没有边界轮廓线！")<br />         )<br />         (progn<br />           (entdel ent)<br />           (command "_.erase" (ssget "c" pt1 pt1 '((0 . "region") (62 . 188))) "")<br />           (setq m 0)<br />           (if (setq ss (ssget "x" '((0 . "region") (62 . 188))))<br />             (progn<br />               (command "_.union" ss "")<br />               (entmod (subst (cons 62 1) (cons 62 188) (entget (setq ent (entlast)))))<br />               (command "_.explode" ent)<br />               (setq ss (ssget "_p"))<br />               (if (= (cdr (assoc 0 (entget (ssname ss 0)))) "REGION")<br />                 (progn<br />                   (setvar "qaflags" 1)<br />                   (command "_.explode" ss "")<br />                   (setq ss (ssget "_p"))<br />                 )<br />               )<br />               (if (ssget "p" '((0 . "spline,ellipse")))<br />                 (progn<br />                   (setq dis (abs (if (setq dis (getreal "\n请输入样条曲线或椭圆的取样距离：<600>")) dis 600.0)))<br />                   (if (= dis 0.0) (setq dis 600.0))<br />                 )<br />               )<br />               (setq n -1)<br />               (repeat (sslength ss)<br />                 (setq ent (ssname ss (setq n (1+ n)))<br />                       name (cdr (assoc 0 (entget ent)))<br />                 )<br />                 (if (or (= name "SPLINE") (= name "ELLIPSE"))<br />                   (progn<br />                     (ssdel ent ss)<br />                     (setq ss (ss_add (spl2arc ent) ss))<br />                     (setq n (1- n))<br />                   )<br />                 )<br />               )<br />               (setq n -1)<br />               (while (setq ent (ssname ss (setq n (1+ n))))<br />                 (if (entget ent)<br />                   (progn<br />                     (command "_.pedit" ent "_y" "_j" ss "" "")<br />                     (setq m (1+ m))<br />                   )<br />                 )<br />               )<br />             )<br />           )<br />           (if (setq ss (ssget "x" '((0 . "*polyline") (62 . 188))))<br />             (progn<br />               (setq n -1)<br />               (repeat (sslength ss)<br />                 (entmod (subst (cons 62 1) (cons 62 188) (entget (ssname ss (setq n (1+ n))))))<br />               )<br />               (setq m (+ m (sslength ss)))<br />             )<br />           )<br />           (if (= m 0)<br />             (prompt "\n没有边界轮廓线！")<br />             (prompt (strcat "\n生成" (itoa m) "条边界轮廓线！"))<br />           )<br />         )<br />       )<br />       (setvar "osmode" os)<br />       (setvar "cecolor" cor)<br />       (setvar "qaflags" qa)<br />       (command "_.undo" "_e")<br />     )<br />   )<br />   (princ)<br /> )<br /> (prompt "\n***边界轮廓线yad_outline***  YAD建筑")<br /> (princ)<br /> [/font]

aaddff

有什么用？？试试cad自己的命令BOUNDARY

aeo

最初由 aaddff 发布
[B]有什么用？？试试cad自己的命令BOUNDARY [/B]

就是BOUNDARY ,简化一点而已

lyy

这只是提供一种实现的lisp途径。
你可以做为片段代码插入你的程序！
当然你如果只是使用且不怕麻烦的话可以用BOUNDARY，
我贴出来只要是因为这里是开发技术讨论！

aaddff

呵呵，不高兴呦,sorry

landc

楼主很厉害啊，等我研究研究。楼主最好讲下编写思路？

wangdaobin

楼主好厉害！！

1028882406@qq.c

啥也不说了，感谢楼主分享哇！

wyldd

感谢楼主分享

wyldd

感谢楼主分享

muwind

感谢分享 正是需要的，虽然还能完全满足要求