[其他]：一位网友需要的R14下Line选择集交点函数

eachy

2. 
   
3. ;;求直线选择集交点, 不过滤重复点
   
4. (defun lnsinters (ss /  n m e1 e2 el el1 p1 p2 p3 p4 intp intps)
   
5.   (setq        n (sslength ss))
   
6.   (while (> n 0)
   
7.     (setq e1 (ssname ss (setq n (1- n)))
   
8.           el (entget e1)
   
9.           m  (1- n)
   
10.           p1 (cdr (assoc 10 el))
    
11.           p2 (cdr (assoc 11 el))
    
12.     )
    
13.     (while (> m 0)
    
14.       (setq e2         (ssname ss m)
    
15.             el1         (entget e2)
    
16.             p3         (cdr (assoc 10 el1))
    
17.             p4         (cdr (assoc 11 el1))
    
18.             intp (inters p1 p2 p3 p4)
    
19.             m         (1- m)
    
20.       )
    
21.       (if intp
    
22.         (setq intps (cons intp intps))
    
23.       )
    
24.     )
    
25.   )
    
26.   intps
    
27. )
    

<br /> ;;求直线选择集交点, 不过滤重复点<br /> (defun lnsinters (ss /  n m e1 e2 el el1 p1 p2 p3 p4 intp intps)<br />   (setq        n (sslength ss))<br />   (while (> n 0)<br />     (setq e1 (ssname ss (setq n (1- n)))<br />           el (entget e1)<br />           m  (1- n)<br />           p1 (cdr (assoc 10 el))<br />           p2 (cdr (assoc 11 el))<br />     )<br />     (while (> m 0)<br />       (setq e2         (ssname ss m)<br />             el1         (entget e2)<br />             p3         (cdr (assoc 10 el1))<br />             p4         (cdr (assoc 11 el1))<br />             intp (inters p1 p2 p3 p4)<br />             m         (1- m)<br />       )<br />       (if intp<br />         (setq intps (cons intp intps))<br />       )<br />     )<br />   )<br />   intps<br /> )<br />

黄卫文

最初由 eachy 发布
[B][CODE]
;;求直线选择集交点, 不过滤重复点
(defun lnsinters (ss /  n m e1 e2 el el1 p1 p2 p3 p4 intp intps)
  (setq        n (sslength ss))
  (while (> n 0)
    (setq e1 (ssname ss (setq n (1- n)))
          el ... [/B]

程序有一处错误
(while (> m 0) 应该改为 (while (>= m 0)
参照上代码加了增加直线平行连续画时的连接也算交点的情况
[php]
(defun lnsinters (ss / n n1 m e1 e2 el el1 p1 p2 p3 p4 intp intps)
  (setq ss (ssget))
  (setq n (sslength ss))
  (setq intps nil)
  (while (> n 0)
    (setq e1 (ssname ss (setq n (1- n)))
          el (entget e1)
          m  (1- n)
          p1 (cdr (assoc 10 el))
          p2 (cdr (assoc 11 el))
    )
    (while (>= m 0)
      (setq e2         (ssname ss m)
            el1         (entget e2)
            p3         (cdr (assoc 10 el1))
            p4         (cdr (assoc 11 el1))
            intp (inters p1 p2 p3 p4)
            m         (1- m)
      )
      (if intp
        (setq intps (cons intp intps))
        (if (or        (setq intp (cdr (member p1 (list p3 p4))))
                (setq intp (cdr (member p2 (list p3 p4))))
            )
          (setq intps (cons intp intps))
        )
      )
    )
  )
  intps
)
[/php]

hmh888888

斑竹:你好，我用不到你的程序，不知能否指点一下。

coolzhb

最初由 eachy 发布
[B][CODE]
;;求直线选择集交点, 不过滤重复点
(defun lnsinters (ss /  n m e1 e2 el el1 p1 p2 p3 p4 intp intps)
... [/B]

谢谢版主，已经下载学习了！

taner

最初由 黄卫文 发布
[B][QUOTE]最初由 eachy 发布
[B][CODE]
;;求直线选择集交点, 不过滤重复点
(defun lnsinters (ss /  n m e1 e2 el el1 p1 p2 p3 p4 intp intps)
  (setq        n (sslength ss))
  (while (> n 0)
    (setq e1... [/B]

測試:

命令: (LNSINTERS ss)

选择对象: 指定对角点: 找到 17 个

选择对象:
(((3405.32 5081.69 0.0)) (3420.14 5066.88 0.0) ((3420.14 5066.88 0.0))
((3416.17 5055.13 0.0)) ((3412.61 5044.56 0.0)) (3422.43 5067.42 0.0) ((3422.43
5067.42 0.0)) ((3418.07 5054.49 0.0)) ((3414.5 5043.92 0.0)) ((3406.02 5082.39
0.0)) (3421.28 5067.15 0.0) ((3421.28 5067.15 0.0)) ((3417.12 5054.81 0.0))
((3413.56 5044.24 0.0)))

點集中爲什麽有的點是((點)),有的是(點)?

修改:
[PHP](defun lnsinters (ss / n n1 m e1 e2 el el1 p1 p2 p3 p4 intp intps)

  (setq n (sslength ss))

  (while (> n 0)
    (setq e1 (ssname ss (setq n (1- n)))
      el (entget e1)
      m  (1- n)
      p1 (cdr (assoc 10 el))
      p2 (cdr (assoc 11 el))
    )
    (while (>= m 0)
      (setq e2     (ssname ss m)
        el1     (entget e2)
        p3     (cdr (assoc 10 el1))
        p4     (cdr (assoc 11 el1))
        intp (inters p1 p2 p3 p4)
        m     (1- m)
      )
      (if intp
    (setq intps (cons intp intps))
    (if (or    (setq intp (cadr (member p1 (list p3 p4))))
        (setq intp (cadr (member p2 (list p3 p4))))
        )
      (setq intps (cons intp intps))
    )
      )
    )
  )
  intps
)
[/PHP]
再改,過濾相同點.
[PHP](defun lst-delsame (pts / pl)
  (while pts
    (setq p (car pts)
          pts (cdr pts)
          pts (vl-remove-if '(lambda (x)
                               (equal x p 1e-10)
                             ) pts
              )
          pl (cons p pl)
    )
  )
  (reverse pl)
)
(defun lines-inters (ss / n n1 m e1 e2 el el1 p1 p2 p3 p4 intp intps)
  (setq n (sslength ss))
  (while (> n 0)
    (setq e1 (ssname ss (setq n (1- n)))
          el (entget e1)
          m (1- n)
          p1 (cdr (assoc 10 el))
          p2 (cdr (assoc 11 el))
    )
    (while (>= m 0)
      (setq e2 (ssname ss m)
            el1 (entget e2)
            p3 (cdr (assoc 10 el1))
            p4 (cdr (assoc 11 el1))
            intp (inters
                   p1
                   p2
                   p3
                   p4
                 )
            m (1- m)
      )
      (if intp
        (setq intps (cons intp intps))
        (if (or
              (setq intp (cadr (member p1 (list p3 p4))))
              (setq intp (cadr (member p2 (list p3 p4))))
            )
          (setq intps (cons intp intps))
        )
      )
    )
  )
  (lst-delsame intps)

)
[/PHP]

eachy

图中有完全重合直线时返回点表中含子表。

tangdeyu

如果在lisp程序中已知p1、p2、p3、p4四个点，如何应用该程序？我试验后，现程序只能人为选择点…………

zwx62504

我也改一个

[PHP]
(defun CheckSamePoint (p / p0 i exit0)
  (setq i -1)
  (while (and intps
              (setq p0 (nth (setq i (1+ i)) intps))
              (not (setq exit0 (equal p p0 1e-4)))
         )
  )
  (princ exit0)
  exit0
)


;;求直线选择集交点, 滤重复点
(defun lnsinters (ss /  n m e1 e2 el el1 p1 p2 p3 p4 intp intps)
(if (and ss (> (sslength ss) 0))(progn
  (setq n -1)
  (while (setq e1 (ssname ss (setq n (1+ n))))
    (setq el (entget e1)
          m  n
          p1 (cdr (assoc 10 el))
          p2 (cdr (assoc 11 el))
    )
    (while (setq e2 (ssname ss (setq m (1+ m))))
      (setq el1         (entget e2)
            p3         (cdr (assoc 10 el1))
            p4         (cdr (assoc 11 el1))
            intp (inters p1 p2 p3 p4)
      )
      (if (and intp (not (CheckSamePoint intp)))
        (setq intps (cons intp intps))
      )
    )
  )
))
  intps
)

;测试
(defun c:tt ()
  (princ (lnsinters (ssget)))
  (princ)
)



[/PHP]

jx2008

以上各位的程序非常好，可否增加其他类型曲线的交点？

linxu100

程序很好，不知道有没有，画角平分线的命令