meflying 请进来帮帮我，谢谢！

huayingjie

meflying 这两天我又研究了一下你给我写的程序，当输入的点排完序后，再往里面追加满足条件长方形的四个角点时，当(> lMax l)成立，且有两个相邻点之间夹有两个角点时，循环程序只能在这两点之间追加一个角点。我改了好多次实在是改不明白啊，再请你帮帮忙吧。以下程序中我给定的点是出现的哪种情况，其中注释的哪一点运行时同样出现哪种情况。 (vl-load-com)
(defun c:test( / ent ptLst ptLstc ptLstn pt ptn pti pta j i n dist l lMax)
(setq pt1 '(200 1000 0) pt2 '(400 1000 0) pt3 '(500 0 0) pt4 '(200 0 0) )
;(setq pt1 '(200 1000 0) pt2 '(400 1000 0) pt3 '(2000 500 0) pt4 '(200 0 0) )
(setq ptc1 '(0 1000 0) )
(setq ptc2 '(2000 1000 0) )
(setq ptc3 '(2000 0 0) )
(setq ptc4 '(0 0 0) )
(command "rectang" ptc1 ptc3 "")
(setq ent (entlast))
;*****获取6个点和四个角点部分,根据需要,自己改成你自己的代码******
(setq ptLst (list pt1 pt2 pt3 pt4 ))
(setq ptLstc (list ptc1 ptc2 ptc3 ptc4))
;**************************************************************** (setq ptLst (mapcar '(lambda(x) (list (vlax-curve-getDistAtPoint ent x) x)) ptLst))
(setq ptLst (vl-sort ptLst '(lambda (x1 x2) (< (car x1) (car x2)))))
(setq ptLstc (mapcar '(lambda(x) (list (vlax-curve-getDistAtPoint ent x) x)) ptLstc))
(setq ptLstc (mapcar 'cadr (vl-sort ptLstc '(lambda (x1 x2) (< (car x1) (car x2))))))
(setq i 1)
(repeat 3
(setq dist (append dist (list (- (car (nth i ptLst)) (car (nth (1- i) ptLst))))))
(setq i (1+ i))
)
(setq lMax (apply 'max dist))
(setq l (+ (caar ptLst) (- (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)) (car (last ptLst)))))
(if (> lMax l)
(progn
(setq n (vl-position lMax dist))
(repeat (1+ n)
(setq ptLst (reverse (cons (car ptLst) (reverse (cdr ptLst)))))
)
)
)
(setq ptLst (mapcar 'cadr ptLst))
(setq i 0)
(repeat (1- (length ptLst))
(setq pt (nth i ptLst))
(setq ptn (nth (1+ i) ptLst))
(setq ptLstn (append ptLstn (list pt)))
(setq j 0)
(setq m t)
(while m
(setq pti (nth j ptLstc))
(cond
((> (vlax-curve-getDistAtPoint ent pt) (vlax-curve-getDistAtPoint ent ptn))
(if (or (equal (vlax-curve-getStartPoint ent) pti 0.001)
(< (vlax-curve-getDistAtPoint ent pti)(vlax-curve-getDistAtPoint ent ptn))
)
(setq ptLstn (append ptLstn (list pti)))
)
)
((< (vlax-curve-getDistAtPoint ent pt) (vlax-curve-getDistAtPoint ent ptn))
(if (and (> (vlax-curve-getDistAtPoint ent pti) (vlax-curve-getDistAtPoint ent pt))
(< (vlax-curve-getDistAtPoint ent pti) (vlax-curve-getDistAtPoint ent ptn))
)
(setq ptLstn (append ptLstn (list pti)))
)
)
)
(setq j (1+ j))
(if (> j 3) (setq m nil))
)
(setq i (1+ i))
)
(setvar "osmode" 0)
(command "color" 170 "")
(command "_.pline")
(mapcar 'command ptLstn)
(command (last ptLst) "")
(command "color" "bylayer" "")
(command "erase" ent "")
)

huayingjie

谁能帮我把这程序修改一下，我想要的是连线中（0，0，0）点也在连线中，即线条是正交的。

meflying

2. (vl-load-com)
3. (defun c:test( / ent ptLst ptLstc ptLstn pt ptn pti ptt pta j i n dist l lMax)
4. ;;;   (setq ent (car (entsel)))
5. ;;;   
6. ;;;   ;*****获取6个点和四个角点部分,根据需要,自己改成你自己的代码******
7. ;;;   (repeat 6
8. ;;;       (setq ptLst (append ptLst (list (getpoint "\nPick a point:"))))
9. ;;;   )
10. ;;;   (repeat 4
11. ;;;       (setq ptLstc (append ptLstc (list (getpoint "\nPick a point:"))))
12. ;;;   )
13. ;;;   ;****************************************************************
14.    
15. (setq pt1 '(200 1000 0)   pt2 '(400 1000 0)   pt3 '(500 0 0) pt4 '(200 0 0)   )
16. ;(setq pt1 '(200 1000 0)   pt2 '(400 1000 0)   pt3 '(2000 500   0) pt4 '(200 0 0)   )
17. (setq ptc1 '(0 1000 0)   )
18. (setq ptc2 '(2000 1000 0)   )
19. (setq ptc3 '(2000 0 0)   )
20. (setq ptc4 '(0 0 0)   )
21. (command "rectang" ptc1 ptc3)
22. (setq ent   (entlast))
23. ;*****获取6个点和四个角点部分,根据需要,自己改成你自己的代码******
24. (setq ptLst (list pt1 pt2 pt3 pt4 ))
25. (setq ptLstc (list ptc1 ptc2 ptc3 ptc4))
26. ;****************************************************************
27.    (setq ptLst (mapcar '(lambda(x) (list (vlax-curve-getDistAtPoint ent x) x)) ptLst))
28.    (setq ptLst (vl-sort ptLst '(lambda (x1 x2) (< (car x1) (car x2)))))
29.    (setq ptLstc (mapcar '(lambda(x) (list (vlax-curve-getDistAtPoint ent x) x)) ptLstc))
30.    (setq ptLstc (mapcar 'cadr (vl-sort ptLstc '(lambda (x1 x2) (< (car x1) (car x2))))))
31.    (setq i 1)
32.    (repeat 3
33.        (setq dist (append dist (list (- (car (nth i ptLst)) (car (nth (1- i) ptLst))))))
34.        (setq i (1+ i))
35.    )
36.    (setq lMax (apply 'max dist))
37.    (setq l (+ (caar ptLst) (- (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)) (car (last ptLst)))))
38.    (if (> lMax l)
39.        (progn
40.            (setq n (vl-position lMax dist))
41.            (repeat (1+ n)
42.   (setq ptLst (reverse (cons (car ptLst) (reverse (cdr ptLst)))))
43.            )
44.        )
45.    )
46.    (setq ptLst (mapcar 'cadr ptLst))
47.    (setq i 0)
48.    (repeat (1- (length ptLst))
49.        (setq pt (nth i ptLst))
50.        (setq ptn (nth (1+ i) ptLst))
51.        (setq ptLstn (append ptLstn (list pt)))
52.        (setq j 0)
53.        (setq m t)
54.        (while m
55.            (setq pti (nth j ptLstc))
56.            (cond
57.   ((> (vlax-curve-getDistAtPoint ent pt)
58.          (vlax-curve-getDistAtPoint ent ptn))
59.    (if (or (equal (vlax-curve-getStartPoint ent) pti 0.001)
60.      (< (vlax-curve-getDistAtPoint ent pti)
61.              (vlax-curve-getDistAtPoint ent ptn)
62.        ))
63.        (setq ptt (append ptt (list pti)))
64.    )
65.    (if (> (vlax-curve-getDistAtPoint ent pti)
66.    (vlax-curve-getDistAtPoint ent pt)
67.        )
68.        (setq ptt (cons pti ptt))
69.    )
70.   );1
71.   ((< (vlax-curve-getDistAtPoint ent pt)
72.          (vlax-curve-getDistAtPoint ent ptn))
73.    (if (and (> (vlax-curve-getDistAtPoint ent pti) (vlax-curve-getDistAtPoint ent pt))
74.        (< (vlax-curve-getDistAtPoint ent pti) (vlax-curve-getDistAtPoint ent ptn)))
75.        (setq ptt (append ptt (list pti)))
76.    )
77.   )
78.            );cond
79.            (setq j (1+ j))
80.            (if (> j 3) (setq m nil))
81.        )
82.        (setq ptLstn (append ptLstn ptt))
83.        (setq ptt nil)
84.        (setq i (1+ i))
85.    )
86.    (setvar "osmode" (logior (getvar "osmode") 16384))
87.    (command "_.pline")
88.    (mapcar 'command ptLstn)
89.    (command (last ptLst) "")
90. )

(vl-load-com) (defun c:test( / ent ptLst ptLstc ptLstn pt ptn pti ptt pta j i n dist l lMax) ;;;   (setq ent (car (entsel))) ;;;    ;;;   ;*****获取6个点和四个角点部分,根据需要,自己改成你自己的代码****** ;;;   (repeat 6 ;;;       (setq ptLst (append ptLst (list (getpoint "\nPick a point:")))) ;;;   ) ;;;   (repeat 4 ;;;       (setq ptLstc (append ptLstc (list (getpoint "\nPick a point:")))) ;;;   ) ;;;   ;****************************************************************     (setq pt1 '(200 1000 0)   pt2 '(400 1000 0)   pt3 '(500 0 0) pt4 '(200 0 0)   ) ;(setq pt1 '(200 1000 0)   pt2 '(400 1000 0)   pt3 '(2000 500   0) pt4 '(200 0 0)   ) (setq ptc1 '(0 1000 0)   ) (setq ptc2 '(2000 1000 0)   ) (setq ptc3 '(2000 0 0)   ) (setq ptc4 '(0 0 0)   ) (command "rectang" ptc1 ptc3) (setq ent   (entlast)) ;*****获取6个点和四个角点部分,根据需要,自己改成你自己的代码****** (setq ptLst (list pt1 pt2 pt3 pt4 )) (setq ptLstc (list ptc1 ptc2 ptc3 ptc4)) ;****************************************************************    (setq ptLst (mapcar '(lambda(x) (list (vlax-curve-getDistAtPoint ent x) x)) ptLst))    (setq ptLst (vl-sort ptLst '(lambda (x1 x2) (< (car x1) (car x2)))))    (setq ptLstc (mapcar '(lambda(x) (list (vlax-curve-getDistAtPoint ent x) x)) ptLstc))    (setq ptLstc (mapcar 'cadr (vl-sort ptLstc '(lambda (x1 x2) (< (car x1) (car x2))))))    (setq i 1)    (repeat 3        (setq dist (append dist (list (- (car (nth i ptLst)) (car (nth (1- i) ptLst))))))        (setq i (1+ i))    )    (setq lMax (apply 'max dist))    (setq l (+ (caar ptLst) (- (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)) (car (last ptLst)))))    (if (> lMax l)        (progn            (setq n (vl-position lMax dist))            (repeat (1+ n)   (setq ptLst (reverse (cons (car ptLst) (reverse (cdr ptLst)))))            )        )    )    (setq ptLst (mapcar 'cadr ptLst))    (setq i 0)    (repeat (1- (length ptLst))        (setq pt (nth i ptLst))        (setq ptn (nth (1+ i) ptLst))        (setq ptLstn (append ptLstn (list pt)))        (setq j 0)        (setq m t)        (while m            (setq pti (nth j ptLstc))            (cond   ((> (vlax-curve-getDistAtPoint ent pt)          (vlax-curve-getDistAtPoint ent ptn))    (if (or (equal (vlax-curve-getStartPoint ent) pti 0.001)      (< (vlax-curve-getDistAtPoint ent pti)              (vlax-curve-getDistAtPoint ent ptn)        ))        (setq ptt (append ptt (list pti)))    )    (if (> (vlax-curve-getDistAtPoint ent pti)    (vlax-curve-getDistAtPoint ent pt)        )        (setq ptt (cons pti ptt))    )   );1   ((< (vlax-curve-getDistAtPoint ent pt)          (vlax-curve-getDistAtPoint ent ptn))    (if (and (> (vlax-curve-getDistAtPoint ent pti) (vlax-curve-getDistAtPoint ent pt))        (< (vlax-curve-getDistAtPoint ent pti) (vlax-curve-getDistAtPoint ent ptn)))        (setq ptt (append ptt (list pti)))    )   )            );cond            (setq j (1+ j))            (if (> j 3) (setq m nil))        )        (setq ptLstn (append ptLstn ptt))        (setq ptt nil)        (setq i (1+ i))    )    (setvar "osmode" (logior (getvar "osmode") 16384))    (command "_.pline")    (mapcar 'command ptLstn)    (command (last ptLst) "") )

huayingjie

谢谢辉哥，让我学到不少东西，总算把这程序看明白了，vlisp里确实有很多好用的命令。(setvar "osmode" (logior (getvar "osmode") 16384)这个用法看你在别的帖子里也发过，真是高人。

meflying

一个纯计算型的方法...你先测试一下

2. (vl-load-com)
3. (defun Getin(pt1 pt2 ptlst / pt pts i)
4.    (cond
5.        ((equal (car pt1) (car pt2) 0.00001) (setq fun 'car))
6.        ((equal (cadr pt1) (cadr pt2) 0.00001) (setq fun 'cadr))
7.        (t (princ "Wrong!") (exit))
8.    )
9.    (setq i 0)
10.    (repeat (length ptlst)
11.        (setq pt (nth i ptlst))
12.        (if (equal ((eval fun) pt1) ((eval fun) pt) 0.00001)
13.            (setq pts (cons pt pts))
14.        )
15.        (setq i (1+ i))
16.    )
17.    (setq pts (mapcar '(lambda (x) (list (distance x pt1) x)) pts))
18.    (setq pts (vl-sort pts '(lambda (x1 x2) (< (car x1) (car x2)))))
19.    (setq pts (mapcar 'cadr pts))
20. )
21. (defun Getlen (ptlstc ptlst / pt pt1 i len lens lent)
22.    (setq i 0 len 0)
23.    (repeat (1- (length ptlst))
24.        (setq pt (nth i ptlst))
25.        (setq pt1 (nth (1+ i) ptlst))
26.        (if (member pt1 ptlstc)
27.            (setq len (+ len (distance pt pt1)))
28.            (progn
29.   (if (= 0 len)
30.      (setq len (distance pt pt1))
31.      (setq len (+ len (distance pt pt1)))
32.   )
33.   (setq lens (append lens (list len)))
34.   (setq len 0)
35.            )
36.        )
37.        (setq i (1+ i))
38.    )
39.    lens
40. )
41. (defun c:test( / ptLst ptLstc pt pt1 pt2 i m n lens)
42. ;;;   (setq ent (car (entsel)));;;   
43. ;;;   ;*****获取6个点和四个角点部分,根据需要,自己改成你自己的代码******
44. ;;;   (repeat 6
45. ;;;       (setq ptLst (append ptLst (list (getpoint "\nPick a point:"))))
46. ;;;   )
47. ;;;   (repeat 4
48. ;;;       (setq ptLstc (append ptLstc (list (getpoint "\nPick a point:"))))
49. ;;;   )
50. ;;;   ;****************************************************************
51.    
52. (setq pt1 '(1700 1000 0)
53.            pt2 '(1800 1000 0)
54.            pt3 '(500 0 0)
55.            pt4 '(200 0 0)
56.            pt5 '(800 0 0)
57.            pt6 '(1900 1000 0)
58.            ;(setq pt1 '(200 1000 0)   pt2 '(400 1000 0)   pt3 '(2000 500   0) pt4 '(200 0 0)   )
59.            ptc1 '(0 1000 0)
60.            ptc2 '(2000 0 0)
61.            ptc3 '(2000 1000 0)
62.            ptc4 '(0 0 0))
63. ;*****获取6个点和四个角点部分,根据需要,自己改成你自己的代码******
64.    (setq ptLst (list pt1 pt2 pt3 pt4 pt5 pt6))
65.    (setq ptLstc (list ptc1 ptc2 ptc3 ptc4))
66.    (setq i 1)
67.    (setq pt1 (list (car ptlstc))   ptlstc (vl-remove (car pt1) ptlstc))
68.    (while (> (length ptlstc) 0)
69.        (setq pt (car ptlstc))
70.        (if (or (equal (car pt) (caar pt1) 0.00001)
71.          (equal (cadr pt) (cadar pt1) 0.00001))
72.            (setq pt1 (cons pt pt1) ptlstc (vl-remove (car pt1) ptlstc))
73.            (setq ptlstc (append (cdr ptlstc) (list (car ptlstc))))
74.        )
75.    )
76.    (setq ptlstc pt1)
77.    (setq ptlstc (append ptlstc (list (car ptlstc))))
78.    (setq i 0 pt2 nil)
79.    (repeat 4
80.        (setq pt (nth i ptlstc)
81.      pt1 (nth (1+ i) ptlstc))
82.        (setq pt2 (append pt2 (cons pt (Getin pt pt1 ptlst))))
83.        (setq i (1+ i))
84.    )
85.    (setq ptlst pt2)
86.    (while (member (car ptlst) ptlstc)
87.        (setq ptlst (cons (last ptlst) (reverse (cdr (reverse ptlst)))))
88.    )
89.    (setq ptlst (append ptlst (list (car ptlst))))
90.    (setq lens (getlen ptlstc ptlst))
91.    (setq n (vl-position (apply 'max lens) lens))
92.    (setq i 0 m 0)
93.    (while (<= m (1+ n))
94.        (setq pt (nth i ptlst))
95.        (if (not (member pt ptlstc))
96.            (setq m (1+ m))
97.        )
98.        (setq i (1+ i))
99.    )
100.    (setq ptlst (reverse (cdr (reverse ptlst))))
101.    (repeat (1- i)
102.        (setq ptlst (append (cdr ptlst) (list (car ptlst))))
103.    )
104.    (while (member (car ptlst) ptlstc) (setq ptlst (cdr ptlst)))
105.    (while (member (last ptlst) ptlstc) (setq ptlst (reverse (cdr (reverse ptlst)))))
106.    
107.    (setvar "osmode" (logior (getvar "osmode") 16384))
108.    (command "_.pline")
109.    (mapcar 'command ptLst)
110.    (command "")
111. )

(vl-load-com) (defun Getin(pt1 pt2 ptlst / pt pts i)    (cond        ((equal (car pt1) (car pt2) 0.00001) (setq fun 'car))        ((equal (cadr pt1) (cadr pt2) 0.00001) (setq fun 'cadr))        (t (princ "Wrong!") (exit))    )    (setq i 0)    (repeat (length ptlst)        (setq pt (nth i ptlst))        (if (equal ((eval fun) pt1) ((eval fun) pt) 0.00001)            (setq pts (cons pt pts))        )        (setq i (1+ i))    )    (setq pts (mapcar '(lambda (x) (list (distance x pt1) x)) pts))    (setq pts (vl-sort pts '(lambda (x1 x2) (< (car x1) (car x2)))))    (setq pts (mapcar 'cadr pts)) ) (defun Getlen (ptlstc ptlst / pt pt1 i len lens lent)    (setq i 0 len 0)    (repeat (1- (length ptlst))        (setq pt (nth i ptlst))        (setq pt1 (nth (1+ i) ptlst))        (if (member pt1 ptlstc)            (setq len (+ len (distance pt pt1)))            (progn   (if (= 0 len)      (setq len (distance pt pt1))      (setq len (+ len (distance pt pt1)))   )   (setq lens (append lens (list len)))   (setq len 0)            )        )        (setq i (1+ i))    )    lens ) (defun c:test( / ptLst ptLstc pt pt1 pt2 i m n lens) ;;;   (setq ent (car (entsel)));;;    ;;;   ;*****获取6个点和四个角点部分,根据需要,自己改成你自己的代码****** ;;;   (repeat 6 ;;;       (setq ptLst (append ptLst (list (getpoint "\nPick a point:")))) ;;;   ) ;;;   (repeat 4 ;;;       (setq ptLstc (append ptLstc (list (getpoint "\nPick a point:")))) ;;;   ) ;;;   ;****************************************************************     (setq pt1 '(1700 1000 0)            pt2 '(1800 1000 0)            pt3 '(500 0 0)            pt4 '(200 0 0)            pt5 '(800 0 0)            pt6 '(1900 1000 0)            ;(setq pt1 '(200 1000 0)   pt2 '(400 1000 0)   pt3 '(2000 500   0) pt4 '(200 0 0)   )            ptc1 '(0 1000 0)            ptc2 '(2000 0 0)            ptc3 '(2000 1000 0)            ptc4 '(0 0 0)) ;*****获取6个点和四个角点部分,根据需要,自己改成你自己的代码******    (setq ptLst (list pt1 pt2 pt3 pt4 pt5 pt6))    (setq ptLstc (list ptc1 ptc2 ptc3 ptc4))    (setq i 1)    (setq pt1 (list (car ptlstc))   ptlstc (vl-remove (car pt1) ptlstc))    (while (> (length ptlstc) 0)        (setq pt (car ptlstc))        (if (or (equal (car pt) (caar pt1) 0.00001)          (equal (cadr pt) (cadar pt1) 0.00001))            (setq pt1 (cons pt pt1) ptlstc (vl-remove (car pt1) ptlstc))            (setq ptlstc (append (cdr ptlstc) (list (car ptlstc))))        )    )    (setq ptlstc pt1)    (setq ptlstc (append ptlstc (list (car ptlstc))))    (setq i 0 pt2 nil)    (repeat 4        (setq pt (nth i ptlstc)      pt1 (nth (1+ i) ptlstc))        (setq pt2 (append pt2 (cons pt (Getin pt pt1 ptlst))))        (setq i (1+ i))    )    (setq ptlst pt2)    (while (member (car ptlst) ptlstc)        (setq ptlst (cons (last ptlst) (reverse (cdr (reverse ptlst)))))    )    (setq ptlst (append ptlst (list (car ptlst))))    (setq lens (getlen ptlstc ptlst))    (setq n (vl-position (apply 'max lens) lens))    (setq i 0 m 0)    (while (<= m (1+ n))        (setq pt (nth i ptlst))        (if (not (member pt ptlstc))            (setq m (1+ m))        )        (setq i (1+ i))    )    (setq ptlst (reverse (cdr (reverse ptlst))))    (repeat (1- i)        (setq ptlst (append (cdr ptlst) (list (car ptlst))))    )    (while (member (car ptlst) ptlstc) (setq ptlst (cdr ptlst)))    (while (member (last ptlst) ptlstc) (setq ptlst (reverse (cdr (reverse ptlst)))))        (setvar "osmode" (logior (getvar "osmode") 16384))    (command "_.pline")    (mapcar 'command ptLst)    (command "") )

huayingjie

好啊，辉哥，你效率真高啊。