一个不是很好的画双线的东西，希望大侠们给点意见，谢谢
;-----超屏幕选择对象----------;(defun feng:more:ssget ( p1 p2 filter nn / pmax pmin li )
(setq pmax (MAPCAR '+ (list nn nn 0) (MAPCAR 'max p1 p2))
pmin (MAPCAR '+ (list (- nn) (- nn) 0) (MAPCAR 'min p1 p2))
li (list '(-4 . "<or") '(-4 . "<and") '(-4 . "<") (cons 10 pmax) '(-4 . ">") (cons 10 pmin) '(-4 . "and>")
'(-4 . "<and") '(-4 . "<") (cons 11 pmax) '(-4 . ">") (cons 11 pmin) '(-4 . "and>") '(-4 . "or>")
)
)
(if filter
(ssget "x" (append filter li))
(ssget "x" li)
)
)
;--------对对象进行交点判定端点修改---------
(defun feng:wall:inters:sort ( slist sname )
(princ slist)
(if (>= (length slist) 3)
(cond
((<= (- (last (cadr slist)) (last (car slist))) 300)
(setq slist (feng:wall:inters:sort (cdr slist) sname))
(if sname (vla-put-StartPoint sname (vlax-3d-point (car (car slist)))))
)
((<= (- (last (last slist)) (last (cadr (REVERSE slist)))) 300)
(setq slist (feng:wall:inters:sort (REVERSE (cdr (REVERSE slist))) sname))
(if sname (vla-put-EndPoint sname (vlax-3d-point (car (last slist)))))
)
)
)
slist
)
;-------对对象进行交点修剪-------------
(defun feng:wall:inters:trim ( ms slist sname tt / n s1 )
(cond
((and (null tt) (> (length slist) 3))
(if sname (vla-Erase sname))
(repeat (/ (setq n (length slist)) 2)
(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")
)
)
(tt
(repeat (/ (setq n (length slist)) 2)
(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")
)
)
)
)
;------------主执行程序------------------
(defun feng:wall:inters ( ms wlist / ss n sname slist inpo ll rl inpo1 )
(setq ss (feng:more:ssget (car (car wlist)) (last (car wlist)) '((0 . "LINE") (8 . "wall")) 70000)
ll (car wlist)
rl (last wlist)
)
(if ss
(repeat (setq n (sslength ss))
(setq sname (vlax-ename->vla-object (ssname ss (setq n (1- n))))
slist (MAPCAR '(LAMBDA (x) (vlax-safearray->list (vlax-variant-value ((EVAL x) sname)))) (list 'vla-get-StartPoint 'vla-get-EndPoint))
inpo (MAPCAR '(LAMBDA (x) (apply 'inters (append x slist))) (list ll rl))
)
(if (setq inpo1 (VL-REMOVE-IF 'null inpo))
(progn
(setq slist (vl-sort (MAPCAR '(LAMBDA (x) (list x (vlax-curve-getDistAtPoint sname x))) (append slist inpo1)) '(LAMBDA (x y) (<= (last x) (last y))))
slist (vl-remove-if '(LAMBDA (x) (null (last x))) slist)
)
(if (>= (length slist) 3) (feng:wall:inters:trim ms (setq slist (feng:wall:inters:sort slist sname)) sname nil))
(setq wlist (MAPCAR 'cons (MAPCAR '(LAMBDA (x y) (if x y nil))
(MAPCAR '(LAMBDA (x) (if (vl-remove-if 'null (MAPCAR '(LAMBDA (y) (EQUAL x y)) (MAPCAR 'car slist))) t nil)) inpo)
inpo
)
wlist))
)
)
)
)
(setq wlist (MAPCAR '(LAMBDA (x)
(vl-sort x '(LAMBDA (y z) (<= (last y) (last z))))
)
(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)))
)
)
(MAPCAR '(LAMBDA (x) (feng:wall:inters:trim ms (feng:wall:inters:sort x nil) nil t)) wlist)
)
;-----------------对角点进行判定---------（有点问题，缩小到一定程度后就不正确）
(defun feng:wall:point:inters ( ss polist po / n interslist templist s1 )
(cond
((null ss) nil)
((ssget po '((0 . "LINE") (8 . "wall"))) t)
((progn
(repeat (setq n (sslength ss))
(setq s1 (entget (ssname ss (setq n (1- n))))
templist (list (cdr (assoc 10 s1)) (cdr (assoc 11 s1)))
interslist (cons (apply 'inters (append polist templist)) interslist)
)
)
(VL-REMOVE-IF 'null interslist)
) t
)
(t nil)
)
)
;------------对角点周边的对象进行提前修改，以便进行超屏幕选择时对象有效--------------
(defun feng:wall:point:trim ( ss temppoint plist1 plist2 po / n sname tempinters linepoint )
(repeat (setq n (sslength ss))
(setq sname (ssname ss (setq n (1- n)))
linepoint (list (cdr (assoc 10 (entget sname))) (cdr (assoc 11 (entget sname))))
)
(if (and (apply 'inters (append linepoint temppoint))
(null (apply 'inters (append linepoint plist1)))
)
(progn
(setq tempinters (apply 'inters (REVERSE (cons 'nil (append linepoint plist2)))))
(if (< (DISTANCE (car linepoint) tempinters) (DISTANCE (last linepoint) tempinters))
(vla-put-StartPoint (vlax-ename->vla-object sname) (vlax-3d-point tempinters))
(vla-put-EndPoint (vlax-ename->vla-object sname) (vlax-3d-point tempinters))
)
(setq po tempinters)
)
)
)
po
)
;----------------对角点周边对象进行提前修改的主执行程序--------------------
(defun feng:wall:point ( p1 p2 lw rw / ang ll rl ss1 ss2 )
(setq ang (angle p1 p2)
ll (MAPCAR 'POLAR (list p1 p2) (MAPCAR '+ (list (/ pi 2) (/ pi 2)) (list ang ang)) (list lw lw))
rl (MAPCAR 'POLAR (list p1 p2) (MAPCAR '+ (list (/ pi 2) (/ pi 2)) (list ang ang)) (list rw rw))
ss1 (ssget "c" (POLAR p1 3.9 300) (POLAR p1 0.78 300) '((0 . "LINE") (8 . "wall")))
ss2 (ssget "c" (POLAR p2 3.9 300) (POLAR p2 0.78 300) '((0 . "LINE") (8 . "wall")))
)
(cond
((and (null (feng:wall:point:inters ss1 ll (car ll))) (feng:wall:point:inters ss1 rl (car rl)))
(setq ll (list (feng:wall:point:trim ss1 (list (POLAR (car rl) ang -300) (cadr rl)) rl ll (car ll)) (last ll)))
)
((and (null (feng:wall:point:inters ss1 rl (car rl))) (feng:wall:point:inters ss1 ll (car ll)))
(setq rl (list (feng:wall:point:trim ss1 (list (POLAR (car ll) ang -300) (cadr ll)) ll rl (car rl)) (last rl)))
)
)
(cond
((and (null (feng:wall:point:inters ss2 ll (cadr ll))) (feng:wall:point:inters ss2 rl (cadr rl)))
(setq ll (list (car ll) (feng:wall:point:trim ss2 (list (car rl) (POLAR (last rl) ang 300)) rl ll (last ll))))
)
((and (null (feng:wall:point:inters ss2 rl (cadr rl))) (feng:wall:point:inters ss2 ll (cadr ll)))
(setq rl (list (car rl) (feng:wall:point:trim ss2 (list (car ll) (POLAR (last ll) ang 300)) ll rl (last rl))))
)
)
(list ll rl)
)
;-----------------命令定义和参数传递------------------------------
(defun c:hq ( / ms layers p1 p2 lw rw tt)
(setq ms (vla-get-ModelSpace (vla-get-activedocument (vlax-get-acad-object)))
layers (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
tt t
lw 90
rw 90
)
(if (null (TBLSEARCH "LAYER" "wall")) (vla-put-color (vla-add layers "wall") 9))
(while (if (and (null p2) (null p1) tt) (setq p1 (getpoint "\n请选择墙的起点:")) tt)
(initget "w W")
(setq p2 (getpoint p1 "\n请选择墙的终点<设置墙宽-w>-左墙90，右墙90:"))
(cond
((or (= p2 "w") (= p2 "W"))
(if (setq lw (getdist "\n请设置左墙宽度<90>:")) lw 90)
(if (setq rw (getdist "\n请设置右墙宽度<90>:")) rw 90)
)
((null p2) (setq tt nil))
(t (feng:wall:inters ms (feng:wall:point p1 p2 lw (- rw))) (setq p1 p2))
)
)
)===================================================================
这是一个画墙线的，采用的是超屏幕选择的，也就是说用全指定对象的判定，对象超过1000个时，会卡顿。
角点处理时，图形缩小到一定范围后就会出现角点处理不正确，很是奇怪。
===================================================================
希望各位大侠能给点建议，有没有什么优化的思路。
mline不是就可以画双线? 稍作修改，缩小不会出错了，但还有别的问题
页:
[1]