有个程序请大家捉捉虫，谢谢各位

夏生生

有个程序，总得不到想要的结果，请大家帮看看，谢谢了（解决后请提供源码），图片如下

测试图形如下



程序如下：

2. (vl-load-com)
   
3. ;;;by bbs.mjtd.com
   
4. ;;;计算曲线交点
   
5. (defun Curveinters (en1 en2 / pl pts)
   
6.   (setq pl  (vlax-invoke (vlax-ename->vla-object en2) 'IntersectWith (vlax-ename->vla-object en1) acExtendNone))
   
7.   (while pl
   
8.     (setq pts (append pts (list (list (car pl) (cadr pl) (caddr pl))))
   
9.    pl (cdr (cdr (cdr pl)))
   
10.    )
    
11.     )
    
12. pts
    
13.   )
    
14. ;;;by bbs.mjtd.com
    
15. ;;;曲线选择集交点
    
16. (defun ssinters (ss / pts en1 en2)
    
17.   (while (> (sslength ss) 1)
    
18.     (setq en1 (ssname ss 0))
    
19.     (ssdel en1 ss)
    
20.     (setq n (sslength ss))
    
21.     (repeat n
    
22.       (setq en2 (ssname ss (setq n (1- n))))
    
23.       (setq pts (append pts (Curveinters en1 en2)))
    
24.       )
    
25.     )
    
26.   pts
    
27.   )
    
28. ;;;by bbs.mjtd.com
    
29. ;;;删除表中重复图元.不支持表中表的重复图元.
    
30. ;;; (gps->lst-delsame '(1 2 1 2 (1 1) (1 2 1 2 1) 1 2 (1 1) (1 2)))
    
31. ;;;  -->(1 2 (1 1) (1 2 1 2 1) (1 2))
    
32. (defun gps->lst-delsame (lst / lstitem lstnew)
    
33.    (foreach lstitem lst
    
34.      (if (not (member lstitem lstnew))
    
35.        (setq lstnew (append lstnew (list lstitem)))
    
36.      )
    
37.    )
    
38.    lstnew
    
39. )
    
40. (defun list1to2(olst / n i lsta lstb)
    
41.   (setq i (length olst))
    
42.   (setq n 0)
    
43.   (while (<= n i)
    
44.     (if (nth n olst) (setq lsta(cons (nth n olst) lsta)))
    
45.     (setq n (+ 2 n))
    
46.     )
    
47.   (setq n 1)
    
48.   (while (<= n i)
    
49.     (if (nth n olst) (setq lstb(cons (nth n olst) lstb)))
    
50.     (setq n (+ 2 n))
    
51.     )   
    
52.   (list (reverse lsta) (reverse lstb))
    
53.   )
    
54. ;;;表内元素两两组合
    
55. ;;;(1 2 3) ((1 2)(2 3))
    
56. (defun lst2&2 (olst / nlst)
    
57.   (repeat (1- (length olst))
    
58.     (setq nlst (cons (list (car olst) (cadr olst)) nlst))
    
59.     (setq olst (cdr olst))
    
60.   )
    
61.   (reverse nlst)
    
62. )
    
63. ;;;==============================
    
64. ;;;by bbs.mjtd.com caoyin
    
65. (defun sort (PNTLST / REC)
    
66.   (defun REC (A B)
    
67.     (if        (equal (car A) (car B) 1E-4)
    
68.       (REC (cdr A) (cdr B))
    
69.       (< (car A) (car B))
    
70.     )
    
71.   )
    
72.   (vl-sort PNTLST 'REC)
    
73. )
    
74. ;;;(1 2 3 4 5 6 7 8) -->(1 4 5 8)
    
75. (defun sort_14 (xx / i n lst)
    
76.   (setq  i 0
    
77.   n (length xx)
    
78.   )
    
79.   (setq lst nil)
    
80.   (while (< i (/ n 4))
    
81.     (setq lst (cons (list (car xx) (nth 3 xx)) lst))
    
82.     (setq xx (cddddr xx)
    
83.     i  (+ 1 i)
    
84.     )
    
85.   )
    
86.   (vl-remove nil (apply 'append (reverse lst)))
    
87. )
    
88. ;;;(1 2 3 4 5 6 7 8) -->(2 3 6 7)
    
89. (defun sort_23 (xx / i n lst)
    
90.   (setq  i 0
    
91.   n (length xx)
    
92.   )
    
93.   (setq lst nil)
    
94.   (while (< i (/ n 4))
    
95.     (setq lst (cons (list (cadr xx) (caddr xx)) lst))
    
96.     (setq xx (cddddr xx)
    
97.     i  (+ 1 i)
    
98.     )
    
99.   )
    
100.   (vl-remove nil (apply 'append (reverse lst)))
     
101. )
     
102. (defun c:jcx (/ ss ptlst kw)
     
103.   (setq ss (ssget '((0 . "line"))))
     
104.   (setq ptlst (gps->lst-delsame (ssinters ss)))
     
105.   (length ptlst)
     
106. ; (setq ptlst (NB_px ptlst (list 0 < <) 1e-6))
     
107. ;;;  (setq ptlst (sort ptlst))
     
108.   (initget "Shang Xia")
     
109.   (setq kw (getkword "\n起始点在上(S)/<起始点在下>(X)>:"))
     
110.   (cond  ((or (= kw nil) (= kw "Xia")) (setq ptlst (sort_14 ptlst)))
     
111.   ((= kw "Shang") (setq ptlst (sort_23 ptlst)))
     
112.   )
     
113.   (setq ptlst (lst2&2 ptlst))
     
114.   (mapcar '(lambda (x)
     
115.        (entmake (list '(0 . "LINE")
     
116.           '(8 . "beam")
     
117.           (cons 10 (car x))
     
118.           (cons 11 (cadr x))
     
119.           )
     
120.        )
     
121.      )
     
122.     ptlst
     
123.   )
     
124. )
     
125. 
     

(vl-load-com)<br /> ;;;by bbs.mjtd.com <br /> ;;;计算曲线交点<br /> (defun Curveinters (en1 en2 / pl pts)<br />   (setq pl  (vlax-invoke (vlax-ename->vla-object en2) 'IntersectWith (vlax-ename->vla-object en1) acExtendNone))<br />   (while pl<br />     (setq pts (append pts (list (list (car pl) (cadr pl) (caddr pl))))<br />    pl (cdr (cdr (cdr pl)))<br />    )<br />     )<br /> pts<br />   )<br /> ;;;by bbs.mjtd.com <br /> ;;;曲线选择集交点<br /> (defun ssinters (ss / pts en1 en2)<br />   (while (> (sslength ss) 1)<br />     (setq en1 (ssname ss 0))<br />     (ssdel en1 ss)<br />     (setq n (sslength ss))<br />     (repeat n<br />       (setq en2 (ssname ss (setq n (1- n))))<br />       (setq pts (append pts (Curveinters en1 en2)))<br />       )<br />     )<br />   pts<br />   )<br /> ;;;by bbs.mjtd.com <br /> ;;;删除表中重复图元.不支持表中表的重复图元.<br /> ;;; (gps->lst-delsame '(1 2 1 2 (1 1) (1 2 1 2 1) 1 2 (1 1) (1 2)))<br /> ;;;  -->(1 2 (1 1) (1 2 1 2 1) (1 2))<br /> (defun gps->lst-delsame (lst / lstitem lstnew)<br />    (foreach lstitem lst<br />      (if (not (member lstitem lstnew))<br />        (setq lstnew (append lstnew (list lstitem)))<br />      )<br />    )<br />    lstnew<br /> )<br /> (defun list1to2(olst / n i lsta lstb)<br />   (setq i (length olst))<br />   (setq n 0)<br />   (while (<= n i)<br />     (if (nth n olst) (setq lsta(cons (nth n olst) lsta)))<br />     (setq n (+ 2 n))<br />     )<br />   (setq n 1)<br />   (while (<= n i)<br />     (if (nth n olst) (setq lstb(cons (nth n olst) lstb)))<br />     (setq n (+ 2 n))<br />     )   <br />   (list (reverse lsta) (reverse lstb))<br />   )<br /> ;;;表内元素两两组合<br /> ;;;(1 2 3) ((1 2)(2 3))<br /> (defun lst2&2 (olst / nlst)<br />   (repeat (1- (length olst))<br />     (setq nlst (cons (list (car olst) (cadr olst)) nlst))<br />     (setq olst (cdr olst))<br />   )<br />   (reverse nlst)<br /> )<br /> ;;;==============================<br /> ;;;by bbs.mjtd.com caoyin<br /> (defun sort (PNTLST / REC)<br />   (defun REC (A B)<br />     (if        (equal (car A) (car B) 1E-4)<br />       (REC (cdr A) (cdr B))<br />       (< (car A) (car B))<br />     )<br />   )<br />   (vl-sort PNTLST 'REC)<br /> )<br /> ;;;(1 2 3 4 5 6 7 8) -->(1 4 5 8)<br /> (defun sort_14 (xx / i n lst)<br />   (setq  i 0<br />   n (length xx)<br />   )<br />   (setq lst nil)<br />   (while (< i (/ n 4))<br />     (setq lst (cons (list (car xx) (nth 3 xx)) lst))<br />     (setq xx (cddddr xx)<br />     i  (+ 1 i)<br />     )<br />   )<br />   (vl-remove nil (apply 'append (reverse lst)))<br /> )<br /> ;;;(1 2 3 4 5 6 7 8) -->(2 3 6 7)<br /> (defun sort_23 (xx / i n lst)<br />   (setq  i 0<br />   n (length xx)<br />   )<br />   (setq lst nil)<br />   (while (< i (/ n 4))<br />     (setq lst (cons (list (cadr xx) (caddr xx)) lst))<br />     (setq xx (cddddr xx)<br />     i  (+ 1 i)<br />     )<br />   )<br />   (vl-remove nil (apply 'append (reverse lst)))<br /> )<br /> (defun c:jcx (/ ss ptlst kw)<br />   (setq ss (ssget '((0 . "line"))))<br />   (setq ptlst (gps->lst-delsame (ssinters ss)))<br />   (length ptlst)<br /> ; (setq ptlst (NB_px ptlst (list 0 < <) 1e-6))<br /> ;;;  (setq ptlst (sort ptlst))<br />   (initget "Shang Xia")<br />   (setq kw (getkword "\n起始点在上(S)/<起始点在下>(X)>:"))<br />   (cond  ((or (= kw nil) (= kw "Xia")) (setq ptlst (sort_14 ptlst)))<br />   ((= kw "Shang") (setq ptlst (sort_23 ptlst)))<br />   )<br />   (setq ptlst (lst2&2 ptlst))<br />   (mapcar '(lambda (x)<br />        (entmake (list '(0 . "LINE")<br />           '(8 . "beam")<br />           (cons 10 (car x))<br />           (cons 11 (cadr x))<br />           )<br />        )<br />      )<br />     ptlst<br />   )<br /> )<br /> <br />

叮咚

试试这个 ………………

xyp1964

Q1241274614

应该根据角度，区分直腹杆，在排序，在画线。

夏生生

Q1241274614 发表于 2012-11-7 09:36
应该根据角度，区分直腹杆，在排序，在画线。

谢谢您的帮助，不过角度35～55之间有些特殊的地方是达不到的，且我是想找到我自己程序的错误在什么地方，并且看看有无更好思路

夏生生

叮咚 发表于 2012-11-7 10:29
试试这个 ………………

谢谢您的解答，达到了需求，请指教问题所在，或提供源码谢谢

ZZXXQQ

1、点未排序
2、缺最后点

游客，本帖隐藏的内容需要发帖数高于 5 才可浏览，你当前发帖数只有 0

lijiao

(vl-load-com)
;;;by bbs.mjtd.com
;;;计算曲线交点
(defun Curveinters (en1 en2 / pl pts)
  (setq pl (vlax-invoke
      (vlax-ename->vla-object en2)
      'IntersectWith
      (vlax-ename->vla-object en1)
      acExtendNone
    )
  )
  (while pl
    (setq pts (append pts (list (list (car pl) (cadr pl) (caddr pl))))
   pl  (cdr (cdr (cdr pl)))
    )
  )
  pts
)
;;;by bbs.mjtd.com
;;;曲线选择集交点
(defun ssinters (ss / pts en1 en2)
  (while (> (sslength ss) 1)
    (setq en1 (ssname ss 0))
    (ssdel en1 ss)
    (setq n (sslength ss))
    (repeat n
      (setq en2 (ssname ss (setq n (1- n))))
      (setq pts (append pts (Curveinters en1 en2)))
    )
  )
  pts
)
;;;by bbs.mjtd.com
;;;删除表中重复图元.不支持表中表的重复图元.
;;; (gps->lst-delsame '(1 2 1 2 (1 1) (1 2 1 2 1) 1 2 (1 1) (1 2)))
;;;  -->(1 2 (1 1) (1 2 1 2 1) (1 2))
(defun gps->lst-delsame (lst / ITEM OUT biaoji)
  (setq out '())
  (foreach item lst
    (setq biaoji (mapcar '(lambda (x)
       (not (equal x item 0.0001))
     )
    out
   )
    )
    (if (apply 'and biaoji)
      (setq out (cons item out))
    )
  )
  (reverse out)
)
(defun list1to2 (olst / n i lsta lstb)
  (setq i (length olst))
  (setq n 0)
  (while (<= n i)
    (if (nth n olst)
      (setq lsta (cons (nth n olst) lsta))
    )
    (setq n (+ 2 n))
  )
  (setq n 1)
  (while (<= n i)
    (if (nth n olst)
      (setq lstb (cons (nth n olst) lstb))
    )
    (setq n (+ 2 n))
  )
  (list (reverse lsta) (reverse lstb))
)
;;;表内元素两两组合
;;;(1 2 3) ((1 2)(2 3))
(defun lst2&2 (olst / nlst)
  (repeat (1- (length olst))
    (setq nlst (cons (list (car olst) (cadr olst)) nlst))
    (setq olst (cdr olst))
  )
  (reverse nlst)
)
;;;==============================
;;;by bbs.mjtd.com caoyin
(defun sort (PNTLST / REC)
  (defun REC (A B)
    (if (equal (car A) (car B) 1E-4)
      (REC (cdr A) (cdr B))
      (< (car A) (car B))
    )
  )
  (vl-sort PNTLST 'REC)
)
;;;(1 2 3 4 5 6 7 8) -->(1 4 5 8)
(defun sort_14 (xx / i n lst)
  (setq i 3
n (length xx)
  )
  (setq lst (list (car xx)))
  (while (<= (1+ i) n)
    (setq lst (cons (nth i xx) lst))
    (setq i (1+ i))
    (if (<= (1+ i) n)
      (setq lst (cons (nth i xx) lst))
    )
    (setq i (+ i 3))
  )
  (reverse lst)
)
;;;(1 2 3 4 5 6 7 8) -->(2 3 6 7)
(defun sort_23 (xx / i n lst)
  (setq i 1
n (length xx)
  )
  (setq lst '())
  (while (<= (1+ i) n)
    (setq lst (cons (nth i xx) lst))
    (setq i (1+ i))
    (if (<= (1+ i) n)
      (setq lst (cons (nth i xx) lst))
    )
    (setq i (+ i 3))
  )
  (reverse lst)
)
(defun c:jcx (/ ss ptlst kw)
  (setq ss (ssget '((0 . "line"))))
  (setq ptlst (gps->lst-delsame (ssinters ss)))
  (setq ptlst (sort ptlst))
  (initget "Shang Xia")
  (setq kw (getkword "\n起始点在上(S)/<起始点在下>(X)>:"))
  (cond ((or (= kw nil) (= kw "Xia")) (setq ptlst (sort_14 ptlst)))
((= kw "Shang") (setq ptlst (sort_23 ptlst)))
  )
  (setq ptlst (lst2&2 ptlst))
  (mapcar '(lambda (x)
      (entmake (list '(0 . "LINE")
       '(8 . "beam")
       (cons 10 (car x))
       (cons 11 (cadr x))
        )
      )
    )
   ptlst
  )
)

xyp1964

容差批处理：

x_s_s_1

非常感谢各位的帮助，