一个不是很好的画双线的东西，希望大侠们给点意见，谢谢

feng582304

2. ;-----超屏幕选择对象----------;
   
3. (defun feng:more:ssget ( p1 p2 filter nn / pmax pmin li )
   
4.   (setq pmax (MAPCAR '+ (list nn nn 0) (MAPCAR 'max p1 p2))
   
5.   pmin (MAPCAR '+ (list (- nn) (- nn) 0) (MAPCAR 'min p1 p2))
   
6.   li (list '(-4 . "<or") '(-4 . "<and") '(-4 . "<") (cons 10 pmax) '(-4 . ">") (cons 10 pmin) '(-4 . "and>")
   
7.      '(-4 . "<and") '(-4 . "<") (cons 11 pmax) '(-4 . ">") (cons 11 pmin) '(-4 . "and>") '(-4 . "or>")
   
8.      )
   
9.   )
   
10.   (if filter
    
11.     (ssget "x" (append filter li))
    
12.     (ssget "x" li)
    
13.     )
    
14.   )
    
15. ;--------对对象进行交点判定端点修改---------
    
16. (defun feng:wall:inters:sort ( slist sname )
    
17.   (princ slist)
    
18.   (if (>= (length slist) 3)
    
19.     (cond
    
20.       ((<= (- (last (cadr slist)) (last (car slist))) 300)
    
21.        (setq slist (feng:wall:inters:sort (cdr slist) sname))
    
22.        (if sname (vla-put-StartPoint sname (vlax-3d-point (car (car slist)))))
    
23.        )
    
24.       ((<= (- (last (last slist)) (last (cadr (REVERSE slist)))) 300)
    
25.        (setq slist (feng:wall:inters:sort (REVERSE (cdr (REVERSE slist))) sname))
    
26.        (if sname (vla-put-EndPoint sname (vlax-3d-point (car (last slist)))))
    
27.        )
    
28.       )
    
29.     )
    
30.   slist
    
31.   )
    
32. ;-------对对象进行交点修剪-------------
    
33. (defun feng:wall:inters:trim ( ms slist sname tt / n s1 )
    
34.   (cond
    
35.     ((and (null tt) (> (length slist) 3))
    
36.      (if sname (vla-Erase sname))
    
37.      (repeat (/ (setq n (length slist)) 2)
    
38.        (vla-put-layer (vla-addline ms (vlax-3d-point (car (nth (setq n (1- n)) slist))) (vlax-3d-point (car (nth (setq n (1- n)) slist)))) "wall")
    
39.        )
    
40.      )
    
41.     (tt
    
42.      (repeat (/ (setq n (length slist)) 2)
    
43.        (vla-put-layer (vla-addline ms (vlax-3d-point (car (nth (setq n (1- n)) slist))) (vlax-3d-point (car (nth (setq n (1- n)) slist)))) "wall")
    
44.        )
    
45.      )
    
46.     )
    
47.   )
    
48. ;------------主执行程序------------------
    
49. (defun feng:wall:inters ( ms wlist / ss n sname slist inpo ll rl inpo1 )
    
50.   (setq ss (feng:more:ssget (car (car wlist)) (last (car wlist)) '((0 . "LINE") (8 . "wall")) 70000)
    
51.   ll (car wlist)
    
52.   rl (last wlist)
    
53.   )
    
54.   (if ss
    
55.     (repeat (setq n (sslength ss))
    
56.       (setq sname (vlax-ename->vla-object (ssname ss (setq n (1- n))))
    
57.       slist (MAPCAR '(LAMBDA (x) (vlax-safearray->list (vlax-variant-value ((EVAL x) sname)))) (list 'vla-get-StartPoint 'vla-get-EndPoint))
    
58.       inpo (MAPCAR '(LAMBDA (x) (apply 'inters (append x slist))) (list ll rl))
    
59.       )
    
60.       (if (setq inpo1 (VL-REMOVE-IF 'null inpo))
    
61.   (progn
    
62.     (setq slist (vl-sort (MAPCAR '(LAMBDA (x) (list x (vlax-curve-getDistAtPoint sname x))) (append slist inpo1)) '(LAMBDA (x y) (<= (last x) (last y))))
    
63.     slist (vl-remove-if '(LAMBDA (x) (null (last x))) slist)
    
64.     )
    
65.     (if (>= (length slist) 3) (feng:wall:inters:trim ms (setq slist (feng:wall:inters:sort slist sname)) sname nil))
    
66.     (setq wlist (MAPCAR 'cons (MAPCAR '(LAMBDA (x y) (if x y nil))
    
67.               (MAPCAR '(LAMBDA (x) (if (vl-remove-if 'null (MAPCAR '(LAMBDA (y) (EQUAL x y)) (MAPCAR 'car slist))) t nil)) inpo)
    
68.               inpo
    
69.               )
    
70.             wlist))
    
71.     )
    
72.   )
    
73.       )
    
74.     )
    
75.   (setq wlist (MAPCAR '(LAMBDA (x)
    
76.        (vl-sort x '(LAMBDA (y z) (<= (last y) (last z))))
    
77.        )
    
78.           (MAPCAR '(LAMBDA (x y) (MAPCAR '(LAMBDA (z) (list z (DISTANCE z y))) x)) (MAPCAR '(LAMBDA (x) (VL-REMOVE-IF 'null x)) wlist) (list (car ll) (car rl)))
    
79.           )
    
80.   )
    
81.   (MAPCAR '(LAMBDA (x) (feng:wall:inters:trim ms (feng:wall:inters:sort x nil) nil t)) wlist)
    
82.   )
    
83. ;-----------------对角点进行判定---------（有点问题，缩小到一定程度后就不正确）
    
84. (defun feng:wall:point:inters ( ss polist po / n interslist templist s1 )
    
85.   (cond
    
86.     ((null ss) nil)
    
87.     ((ssget po '((0 . "LINE") (8 . "wall"))) t)
    
88.     ((progn
    
89.        (repeat (setq n (sslength ss))
    
90.    (setq s1 (entget (ssname ss (setq n (1- n))))
    
91.          templist (list (cdr (assoc 10 s1)) (cdr (assoc 11 s1)))
    
92.          interslist (cons (apply 'inters (append polist templist)) interslist)
    
93.          )
    
94.    )
    
95.        (VL-REMOVE-IF 'null interslist)
    
96.        ) t
    
97.      )
    
98.     (t nil)
    
99.     )
    
100.   )
     
101. ;------------对角点周边的对象进行提前修改，以便进行超屏幕选择时对象有效--------------
     
102. (defun feng:wall:point:trim ( ss temppoint plist1 plist2 po / n sname tempinters linepoint )
     
103.   (repeat (setq n (sslength ss))
     
104.     (setq sname (ssname ss (setq n (1- n)))
     
105.     linepoint (list (cdr (assoc 10 (entget sname))) (cdr (assoc 11 (entget sname))))
     
106.     )
     
107.     (if (and (apply 'inters (append linepoint temppoint))
     
108.        (null (apply 'inters (append linepoint plist1)))
     
109.        )
     
110.       (progn
     
111.   (setq tempinters (apply 'inters (REVERSE (cons 'nil (append linepoint plist2)))))
     
112.   (if (< (DISTANCE (car linepoint) tempinters) (DISTANCE (last linepoint) tempinters))
     
113.     (vla-put-StartPoint (vlax-ename->vla-object sname) (vlax-3d-point tempinters))
     
114.     (vla-put-EndPoint (vlax-ename->vla-object sname) (vlax-3d-point tempinters))
     
115.     )
     
116.   (setq po tempinters)
     
117.   )
     
118.       )
     
119.     )
     
120.   po
     
121.   )
     
122. ;----------------对角点周边对象进行提前修改的主执行程序--------------------
     
123. (defun feng:wall:point ( p1 p2 lw rw / ang ll rl ss1 ss2 )
     
124.   (setq ang (angle p1 p2)
     
125.   ll (MAPCAR 'POLAR (list p1 p2) (MAPCAR '+ (list (/ pi 2) (/ pi 2)) (list ang ang)) (list lw lw))
     
126.   rl (MAPCAR 'POLAR (list p1 p2) (MAPCAR '+ (list (/ pi 2) (/ pi 2)) (list ang ang)) (list rw rw))
     
127.   ss1 (ssget "c" (POLAR p1 3.9 300) (POLAR p1 0.78 300) '((0 . "LINE") (8 . "wall")))
     
128.   ss2 (ssget "c" (POLAR p2 3.9 300) (POLAR p2 0.78 300) '((0 . "LINE") (8 . "wall")))
     
129.   )
     
130.   (cond
     
131.     ((and (null (feng:wall:point:inters ss1 ll (car ll))) (feng:wall:point:inters ss1 rl (car rl)))
     
132.      (setq ll (list (feng:wall:point:trim ss1 (list (POLAR (car rl) ang -300) (cadr rl)) rl ll (car ll)) (last ll)))
     
133.      )
     
134.     ((and (null (feng:wall:point:inters ss1 rl (car rl))) (feng:wall:point:inters ss1 ll (car ll)))
     
135.      (setq rl (list (feng:wall:point:trim ss1 (list (POLAR (car ll) ang -300) (cadr ll)) ll rl (car rl)) (last rl)))
     
136.      )
     
137.     )
     
138.   (cond
     
139.     ((and (null (feng:wall:point:inters ss2 ll (cadr ll))) (feng:wall:point:inters ss2 rl (cadr rl)))
     
140.      (setq ll (list (car ll) (feng:wall:point:trim ss2 (list (car rl) (POLAR (last rl) ang 300)) rl ll (last ll))))
     
141.      )
     
142.     ((and (null (feng:wall:point:inters ss2 rl (cadr rl))) (feng:wall:point:inters ss2 ll (cadr ll)))
     
143.      (setq rl (list (car rl) (feng:wall:point:trim ss2 (list (car ll) (POLAR (last ll) ang 300)) ll rl (last rl))))
     
144.      )
     
145.     )
     
146.   (list ll rl)
     
147.   )
     
148. ;-----------------命令定义和参数传递------------------------------
     
149. (defun c:hq ( / ms layers p1 p2 lw rw tt)
     
150.   (setq ms (vla-get-ModelSpace (vla-get-activedocument (vlax-get-acad-object)))
     
151.   layers (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
     
152.   tt t
     
153.   lw 90
     
154.   rw 90
     
155.   )
     
156.   (if (null (TBLSEARCH "LAYER" "wall")) (vla-put-color (vla-add layers "wall") 9))
     
157.   (while (if (and (null p2) (null p1) tt) (setq p1 (getpoint "\n请选择墙的起点:")) tt)
     
158.     (initget "w W")
     
159.     (setq p2 (getpoint p1 "\n请选择墙的终点<设置墙宽-w>-左墙90，右墙90:"))
     
160.     (cond
     
161.       ((or (= p2 "w") (= p2 "W"))
     
162.        (if (setq lw (getdist "\n请设置左墙宽度<90>:")) lw 90)
     
163.        (if (setq rw (getdist "\n请设置右墙宽度<90>:")) rw 90)
     
164.        )
     
165.       ((null p2) (setq tt nil))
     
166.       (t (feng:wall:inters ms (feng:wall:point p1 p2 lw (- rw))) (setq p1 p2))
     
167.       )
     
168.     )
     
169.   )

;-----超屏幕选择对象----------;<br /> (defun feng:more:ssget ( p1 p2 filter nn / pmax pmin li )<br />   (setq pmax (MAPCAR '+ (list nn nn 0) (MAPCAR 'max p1 p2))<br />   pmin (MAPCAR '+ (list (- nn) (- nn) 0) (MAPCAR 'min p1 p2))<br />   li (list '(-4 . "<or") '(-4 . "<and") '(-4 . "<") (cons 10 pmax) '(-4 . ">") (cons 10 pmin) '(-4 . "and>")<br />      '(-4 . "<and") '(-4 . "<") (cons 11 pmax) '(-4 . ">") (cons 11 pmin) '(-4 . "and>") '(-4 . "or>")<br />      )<br />   )<br />   (if filter<br />     (ssget "x" (append filter li))<br />     (ssget "x" li)<br />     )<br />   )<br /> ;--------对对象进行交点判定端点修改---------<br /> (defun feng:wall:inters:sort ( slist sname )<br />   (princ slist)<br />   (if (>= (length slist) 3)<br />     (cond<br />       ((<= (- (last (cadr slist)) (last (car slist))) 300)<br />        (setq slist (feng:wall:inters:sort (cdr slist) sname))<br />        (if sname (vla-put-StartPoint sname (vlax-3d-point (car (car slist)))))<br />        )<br />       ((<= (- (last (last slist)) (last (cadr (REVERSE slist)))) 300)<br />        (setq slist (feng:wall:inters:sort (REVERSE (cdr (REVERSE slist))) sname))<br />        (if sname (vla-put-EndPoint sname (vlax-3d-point (car (last slist)))))<br />        )<br />       )<br />     )<br />   slist<br />   )<br /> ;-------对对象进行交点修剪-------------<br /> (defun feng:wall:inters:trim ( ms slist sname tt / n s1 )<br />   (cond<br />     ((and (null tt) (> (length slist) 3))<br />      (if sname (vla-Erase sname))<br />      (repeat (/ (setq n (length slist)) 2)<br />        (vla-put-layer (vla-addline ms (vlax-3d-point (car (nth (setq n (1- n)) slist))) (vlax-3d-point (car (nth (setq n (1- n)) slist)))) "wall")<br />        )<br />      )<br />     (tt<br />      (repeat (/ (setq n (length slist)) 2)<br />        (vla-put-layer (vla-addline ms (vlax-3d-point (car (nth (setq n (1- n)) slist))) (vlax-3d-point (car (nth (setq n (1- n)) slist)))) "wall")<br />        )<br />      )<br />     )<br />   )<br /> ;------------主执行程序------------------<br /> (defun feng:wall:inters ( ms wlist / ss n sname slist inpo ll rl inpo1 )<br />   (setq ss (feng:more:ssget (car (car wlist)) (last (car wlist)) '((0 . "LINE") (8 . "wall")) 70000)<br />   ll (car wlist)<br />   rl (last wlist)<br />   )<br />   (if ss<br />     (repeat (setq n (sslength ss))<br />       (setq sname (vlax-ename->vla-object (ssname ss (setq n (1- n))))<br />       slist (MAPCAR '(LAMBDA (x) (vlax-safearray->list (vlax-variant-value ((EVAL x) sname)))) (list 'vla-get-StartPoint 'vla-get-EndPoint))<br />       inpo (MAPCAR '(LAMBDA (x) (apply 'inters (append x slist))) (list ll rl))<br />       )<br />       (if (setq inpo1 (VL-REMOVE-IF 'null inpo))<br />   (progn<br />     (setq slist (vl-sort (MAPCAR '(LAMBDA (x) (list x (vlax-curve-getDistAtPoint sname x))) (append slist inpo1)) '(LAMBDA (x y) (<= (last x) (last y))))<br />     slist (vl-remove-if '(LAMBDA (x) (null (last x))) slist)<br />     )<br />     (if (>= (length slist) 3) (feng:wall:inters:trim ms (setq slist (feng:wall:inters:sort slist sname)) sname nil))<br />     (setq wlist (MAPCAR 'cons (MAPCAR '(LAMBDA (x y) (if x y nil))<br />               (MAPCAR '(LAMBDA (x) (if (vl-remove-if 'null (MAPCAR '(LAMBDA (y) (EQUAL x y)) (MAPCAR 'car slist))) t nil)) inpo)<br />               inpo<br />               )<br />             wlist))<br />     )<br />   )<br />       )<br />     )<br />   (setq wlist (MAPCAR '(LAMBDA (x)<br />        (vl-sort x '(LAMBDA (y z) (<= (last y) (last z))))<br />        )<br />           (MAPCAR '(LAMBDA (x y) (MAPCAR '(LAMBDA (z) (list z (DISTANCE z y))) x)) (MAPCAR '(LAMBDA (x) (VL-REMOVE-IF 'null x)) wlist) (list (car ll) (car rl)))<br />           )<br />   )<br />   (MAPCAR '(LAMBDA (x) (feng:wall:inters:trim ms (feng:wall:inters:sort x nil) nil t)) wlist)<br />   )<br /> ;-----------------对角点进行判定---------（有点问题，缩小到一定程度后就不正确）<br /> (defun feng:wall:point:inters ( ss polist po / n interslist templist s1 )<br />   (cond<br />     ((null ss) nil)<br />     ((ssget po '((0 . "LINE") (8 . "wall"))) t)<br />     ((progn<br />        (repeat (setq n (sslength ss))<br />    (setq s1 (entget (ssname ss (setq n (1- n))))<br />          templist (list (cdr (assoc 10 s1)) (cdr (assoc 11 s1)))<br />          interslist (cons (apply 'inters (append polist templist)) interslist)<br />          )<br />    )<br />        (VL-REMOVE-IF 'null interslist)<br />        ) t<br />      )<br />     (t nil)<br />     )<br />   )<br /> ;------------对角点周边的对象进行提前修改，以便进行超屏幕选择时对象有效--------------<br /> (defun feng:wall:point:trim ( ss temppoint plist1 plist2 po / n sname tempinters linepoint )<br />   (repeat (setq n (sslength ss))<br />     (setq sname (ssname ss (setq n (1- n)))<br />     linepoint (list (cdr (assoc 10 (entget sname))) (cdr (assoc 11 (entget sname))))<br />     )<br />     (if (and (apply 'inters (append linepoint temppoint))<br />        (null (apply 'inters (append linepoint plist1)))<br />        )<br />       (progn<br />   (setq tempinters (apply 'inters (REVERSE (cons 'nil (append linepoint plist2)))))<br />   (if (< (DISTANCE (car linepoint) tempinters) (DISTANCE (last linepoint) tempinters))<br />     (vla-put-StartPoint (vlax-ename->vla-object sname) (vlax-3d-point tempinters))<br />     (vla-put-EndPoint (vlax-ename->vla-object sname) (vlax-3d-point tempinters))<br />     )<br />   (setq po tempinters)<br />   )<br />       )<br />     )<br />   po<br />   )<br /> ;----------------对角点周边对象进行提前修改的主执行程序--------------------<br /> (defun feng:wall:point ( p1 p2 lw rw / ang ll rl ss1 ss2 )<br />   (setq ang (angle p1 p2)<br />   ll (MAPCAR 'POLAR (list p1 p2) (MAPCAR '+ (list (/ pi 2) (/ pi 2)) (list ang ang)) (list lw lw))<br />   rl (MAPCAR 'POLAR (list p1 p2) (MAPCAR '+ (list (/ pi 2) (/ pi 2)) (list ang ang)) (list rw rw))<br />   ss1 (ssget "c" (POLAR p1 3.9 300) (POLAR p1 0.78 300) '((0 . "LINE") (8 . "wall")))<br />   ss2 (ssget "c" (POLAR p2 3.9 300) (POLAR p2 0.78 300) '((0 . "LINE") (8 . "wall")))<br />   )<br />   (cond<br />     ((and (null (feng:wall:point:inters ss1 ll (car ll))) (feng:wall:point:inters ss1 rl (car rl)))<br />      (setq ll (list (feng:wall:point:trim ss1 (list (POLAR (car rl) ang -300) (cadr rl)) rl ll (car ll)) (last ll)))<br />      )<br />     ((and (null (feng:wall:point:inters ss1 rl (car rl))) (feng:wall:point:inters ss1 ll (car ll)))<br />      (setq rl (list (feng:wall:point:trim ss1 (list (POLAR (car ll) ang -300) (cadr ll)) ll rl (car rl)) (last rl)))<br />      )<br />     )<br />   (cond<br />     ((and (null (feng:wall:point:inters ss2 ll (cadr ll))) (feng:wall:point:inters ss2 rl (cadr rl)))<br />      (setq ll (list (car ll) (feng:wall:point:trim ss2 (list (car rl) (POLAR (last rl) ang 300)) rl ll (last ll))))<br />      )<br />     ((and (null (feng:wall:point:inters ss2 rl (cadr rl))) (feng:wall:point:inters ss2 ll (cadr ll)))<br />      (setq rl (list (car rl) (feng:wall:point:trim ss2 (list (car ll) (POLAR (last ll) ang 300)) ll rl (last rl))))<br />      )<br />     )<br />   (list ll rl)<br />   )<br /> ;-----------------命令定义和参数传递------------------------------<br /> (defun c:hq ( / ms layers p1 p2 lw rw tt)<br />   (setq ms (vla-get-ModelSpace (vla-get-activedocument (vlax-get-acad-object)))<br />   layers (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))<br />   tt t<br />   lw 90<br />   rw 90<br />   )<br />   (if (null (TBLSEARCH "LAYER" "wall")) (vla-put-color (vla-add layers "wall") 9))<br />   (while (if (and (null p2) (null p1) tt) (setq p1 (getpoint "\n请选择墙的起点:")) tt)<br />     (initget "w W")<br />     (setq p2 (getpoint p1 "\n请选择墙的终点<设置墙宽-w>-左墙90，右墙90:"))<br />     (cond<br />       ((or (= p2 "w") (= p2 "W"))<br />        (if (setq lw (getdist "\n请设置左墙宽度<90>:")) lw 90)<br />        (if (setq rw (getdist "\n请设置右墙宽度<90>:")) rw 90)<br />        )<br />       ((null p2) (setq tt nil))<br />       (t (feng:wall:inters ms (feng:wall:point p1 p2 lw (- rw))) (setq p1 p2))<br />       )<br />     )<br />   )

===================================================================
这是一个画墙线的，采用的是超屏幕选择的，也就是说用全指定对象的判定，对象超过1000个时，会卡顿。
角点处理时，图形缩小到一定范围后就会出现角点处理不正确，很是奇怪。
===================================================================
希望各位大侠能给点建议，有没有什么优化的思路。

kwok

mline不是就可以画双线?

a197712939

稍作修改，缩小不会出错了，但还有别的问题