各位大神，求两个图层的线的交点形成圆

664571221

各位大神，求两个图层的线的交点形成圆，输入tt，提示选择第一个图层，然后提示选择第二个图层，然后选择图纸范围，范围内的图层一和图层二的线的交点形成圆形

x_s_s_1

1. (defun c:tt  (/ en en1 en2 int lst1 lst2 n pt space ss)
   
2.   (setq  en1   (car (entsel "\n图层1"))
   
3.   en2   (car (entsel "\n图层2"))
   
4.   ss    (ssget "w"
   
5.          (setq pt (getpoint "\n窗口第一点:"))
   
6.          (getcorner pt "\n窗口第二点:")
   
7.          (list '(-4 . "<or")
   
8.          (setq en1 (assoc 8 (entget en1)))
   
9.          (setq en2 (assoc 8 (entget en2)))
   
10.          '(-4 . "or>")))
    
11.   space (vlax-get-property
    
12.     (vlax-get-property
    
13.       (vlax-get-acad-object)
    
14.       "activedocument")
    
15.     "ModelSpace"))
    
16.   (repeat (setq n (sslength ss))
    
17.     (setq en (ssname ss (setq n (1- n))))
    
18.     (if  (equal en1 (assoc 8 (entget en)))
    
19.       (setq lst1 (cons (vlax-ename->vla-object en) lst1))
    
20.       (setq lst2 (cons (vlax-ename->vla-object en) lst2))))
    
21.   (while lst1
    
22.     (setq en1  (car lst1)
    
23.     lst1 (cdr lst1))
    
24.     (foreach n  lst2
    
25.       (if (null  (vl-catch-all-error-p
    
26.       (setq  int (vl-catch-all-apply
    
27.             'vlax-safearray->list
    
28.             (list (vlax-variant-value
    
29.               (vlax-invoke-method
    
30.           en1
    
31.           "intersectwith"
    
32.           n
    
33.           acextendnone)))))))
    
34.   (while int
    
35.     (vlax-invoke-method
    
36.       space
    
37.       "addcircle"
    
38.       (vlax-3d-point (car int) (cadr int) (caddr int))
    
39.       50)
    
40.     (setq int (cdddr int)))))))

(defun c:tt  (/ en en1 en2 int lst1 lst2 n pt space ss)<br />   (setq  en1   (car (entsel "\n图层1"))<br />   en2   (car (entsel "\n图层2"))<br />   ss    (ssget "w"<br />          (setq pt (getpoint "\n窗口第一点:"))<br />          (getcorner pt "\n窗口第二点:")<br />          (list '(-4 . "<or")<br />          (setq en1 (assoc 8 (entget en1)))<br />          (setq en2 (assoc 8 (entget en2)))<br />          '(-4 . "or>")))<br />   space (vlax-get-property<br />     (vlax-get-property<br />       (vlax-get-acad-object)<br />       "activedocument")<br />     "ModelSpace"))<br />   (repeat (setq n (sslength ss))<br />     (setq en (ssname ss (setq n (1- n))))<br />     (if  (equal en1 (assoc 8 (entget en)))<br />       (setq lst1 (cons (vlax-ename->vla-object en) lst1))<br />       (setq lst2 (cons (vlax-ename->vla-object en) lst2))))<br />   (while lst1<br />     (setq en1  (car lst1)<br />     lst1 (cdr lst1))<br />     (foreach n  lst2<br />       (if (null  (vl-catch-all-error-p<br />       (setq  int (vl-catch-all-apply<br />             'vlax-safearray->list<br />             (list (vlax-variant-value<br />               (vlax-invoke-method<br />           en1<br />           "intersectwith"<br />           n<br />           acextendnone)))))))<br />   (while int<br />     (vlax-invoke-method<br />       space<br />       "addcircle"<br />       (vlax-3d-point (car int) (cadr int) (caddr int))<br />       50)<br />     (setq int (cdddr int)))))))

我也来凑个热闹，极不严谨的代码

vitalgg

1. (defun c:tt ()
   
2.   (setq lay1 (entity:getdxf(car (entsel (@:speak"请点选第一个图层上的图形:"))) 8))
   
3.   (setq lay2 (entity:getdxf(car (entsel (@:speak"请点选第二个图层上的图形:"))) 8))
   
4.   (setq pt2 (getcorner (setq pt1(getpoint (@:speak"矩形第一角点:")))(@:speak"矩形第二角点:")))
   
5.   (setq ents1 (pickset:to-list(ssget "w" pt1 pt2  (list (cons 0 (@:get-config '@curve:types))(cons 8 lay1)))))
   
6.   (setq ents2 (pickset:to-list(ssget "w" pt1 pt2  (list (cons 0 (@:get-config '@curve:types))(cons 8 lay2)))))
   
7.   (setq res nil)
   
8.   (foreach ent1 ents1
   
9.     (foreach ent2 ents2
   
10.       (setq res (append res
    
11.                     (curve:inters ent1 ent2 acextendnone)
    
12.       ))))
    
13.   (entity:make-circle
    
14.     (vl-remove nil res)
    
15.     50
    
16.   ))

(defun c:tt ()<br />   (setq lay1 (entity:getdxf(car (entsel (@:speak"请点选第一个图层上的图形:"))) 8))<br />   (setq lay2 (entity:getdxf(car (entsel (@:speak"请点选第二个图层上的图形:"))) 8))<br />   (setq pt2 (getcorner (setq pt1(getpoint (@:speak"矩形第一角点:")))(@:speak"矩形第二角点:")))<br />   (setq ents1 (pickset:to-list(ssget "w" pt1 pt2  (list (cons 0 (@:get-config '@curve:types))(cons 8 lay1)))))<br />   (setq ents2 (pickset:to-list(ssget "w" pt1 pt2  (list (cons 0 (@:get-config '@curve:types))(cons 8 lay2)))))<br />   (setq res nil)<br />   (foreach ent1 ents1<br />     (foreach ent2 ents2<br />       (setq res (append res<br />                     (curve:inters ent1 ent2 acextendnone)<br />       ))))<br />   (entity:make-circle <br />     (vl-remove nil res)<br />     50<br />   ))

如果无法播放，请点击此处在新窗口打开

zhaoxt

稍微提点小意见。提问了问题有人解答，还是要表示下感谢的。我一开始以为你没登陆网站，但后来却看到你昨天还极有耐心的翻出了2008年的一个老帖，还在问人家要代码当然，这也可能只是是你疏忽忘记了 ，我想说的是，这个论坛对初学LISP的人真的很有用，都这样的话大家回复的热情就越来越少，能想象一下只有新手提问却无人回答的场面吗。。。。。。。。。。。。

664571221

zhaoxt 发表于 2023-5-2 07:10
稍微提点小意见。提问了问题有人解答，还是要表示下感谢的。我一开始以为你没登陆网站，但后来却看到你昨天 ...

我了楼上那位已经再qq上深入交流了，谢谢你提的意见，我混迹论坛十几年，基本都是熟人了

664571221

zhaoxt 发表于 2023-5-2 07:10
稍微提点小意见。提问了问题有人解答，还是要表示下感谢的。我一开始以为你没登陆网站，但后来却看到你昨天 ...

谢谢你啊，你也是一位非常热心的人

664571221

x_s_s_1 发表于 2023-5-2 11:38
我也来凑个热闹，极不严谨的代码

大佬你可以更加严谨点

橡皮

x_s_s_1 发表于 2023-5-2 11:38
我也来凑个热闹，极不严谨的代码

大家是真谦虚啊

jkop

感谢大神提供源码供我辈学习。

664571221

jkop 发表于 2023-5-25 09:31
感谢大神提供源码供我辈学习。

期待你变大神.....