在交点上插入图块或圆的lisp程序

yan19851204

http://bbs.mjtd.com/thread-86381-1-1.html论坛看到的在交点插入方框的程序，但我希望插入的是圆或者块，哪位朋友能够帮忙改一下吗？谢谢！

• ;;;计算曲线交点
•   )
  
  

arno_tm

谢谢分享，很牛X

墨者

谢谢楼主分享

yan19851204

插入方框代码：
;;;计算曲线交点
(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
  )
;;;曲线选择集交点
(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
  )
;;;画框
(defun drawbox (pt d / r en ang)
  (setq en (ssget pt '((0 . "*line"))))
  (setq en (ssname en 0))
  (setq ang (angle pt (mapcar '+ pt (vlax-curve-getFirstDeriv en (vlax-curve-getParamAtPoint en (setq pt (vlax-curve-getclosestpointto en pt)))))))
  (setq r (* d (sqrt 2)))
  ;;此处也可改插入框的图块
  (command "rectang" (polar pt (* pi 1.25) r) (polar pt (* pi 0.25) r ) )
  (command "rotate" (entlast) "" pt (/ (* 180 ang) pi))
  )
;;;使用实例
(defun c:tt(/ p1 p2 d minX minY maxX maxY pt pts p1 p2 ss os cmdecho)
  (setq os (getvar "osmode"))
  (setq cmdecho (getvar "cmdecho"))
  (setvar "osmode" 0)
  (setvar "cmdecho" 0)
  (setq d (getreal "\n插入框大小<1.0>"))
  (if (null d) (setq d 1.))
  (while (and
           (setq p1 (getpoint "\n选择图框左下角："))
           (setq p2 (GETCORNER p1 "\n选择图框左下角："))
           )
    (setq minX (apply 'min (mapcar 'car (list p1 p2)))
          minY (apply 'min (mapcar 'cadr (list p1 p2)))
          maxX (apply 'max (mapcar 'car (list p1 p2)))
          maxY (apply 'max (mapcar 'cadr (list p1 p2)))
          )
    (grvecs (list 1 (list minx miny) (list maxx miny)
                  1 (list maxx miny) (list maxx maxy)
                  1 (list maxx maxy) (list minx maxy)
                  1 (list minx maxy) (list minx miny)
                  )
            )
    (setq ss (ssget "c" p1 p2 '((0 . "*line"))))
    (if ss
      (progn
        (setq pts (ssinters ss))
        (if pts
          (foreach pt pts
            (if (and (>= maxX (car pt) minX)
                     (>= maxY (cadr pt) minY)
                     )
              (drawbox pt d)
              )
            )
          )
        )
      )
    (princ "\n ***回车键结束***")
    )
(setvar "osmode" os)
  (setvar "cmdecho" cmdecho)
  (princ)
  )

Andyhon

;;此处也可改插入框的图块
;|
  (command "rectang" (polar pt (* pi 1.25) r) (polar pt (* pi 0.25) r ) )
  (command "rotate" (entlast) "" pt (/ (* 180 ang) pi))
|;

(command "Insert" "ABlockName" pt 1 1 0)       ; ABlockName ==>块名

yan19851204

回复 Andyhon 的帖子

谢谢您回复，但好像没有效果啊，能否帮忙写全呢？

xyp1964

2. ;; 需要e派工具箱的支持
   
3. (defun c:tt ()
   
4.   (CMDLA0)
   
5.   (if (setq ss (ssget '((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))))
   
6.     (progn
   
7.       (setq ptn (xyp-Get-CurveInters ss))
   
8.       (foreach pt ptn
   
9. (xyp-circle pt 200)  ;200为圆半径
   
10.       )
    
11.     )
    
12.   )
    
13.   (CMDLA1)
    
14. )
    

;; 需要e派工具箱的支持<br /> (defun c:tt ()<br />   (CMDLA0)<br />   (if (setq ss (ssget '((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))))<br />     (progn<br />       (setq ptn (xyp-Get-CurveInters ss))<br />       (foreach pt ptn<br /> (xyp-circle pt 200)  ;200为圆半径<br />       )<br />     )<br />   )<br />   (CMDLA1)<br /> )<br />

chpmould

yan19851204 发表于 2011-6-18 12:48
回复 Andyhon 的帖子

谢谢您回复，但好像没有效果啊，能否帮忙写全呢？

Andyhon的方法就是你需要的按交点插入块,你可以直接就这样用

2. (defun c:test()
   
3. (setq ss(ssget '((0 . "line"))))
   
4. (if ss(progn(setq pts(ssinters ss))
   
5. (if pts(foreach pt pts(command "Insert" "ABlockName" pt 1 1 0)))))
   
6. )

(defun c:test()<br /> (setq ss(ssget '((0 . "line"))))<br /> (if ss(progn(setq pts(ssinters ss))<br /> (if pts(foreach pt pts(command "Insert" "ABlockName" pt 1 1 0)))))<br /> )

【KAIXIN】

http://bbs.mjtd.com/thread-91172-1-1.html

zyhandw

改了一下，插入圆的程序如下：

2. ;;;计算曲线交点
   
3. (defun Curveinters (en1 en2 / pl pts)
   
4.   (setq pl  (vlax-invoke (vlax-ename->vla-object en2) 'IntersectWith (vlax-ename->vla-object en1) acExtendNone))
   
5.   (while pl
   
6.     (setq pts (append pts (list (list (car pl) (cadr pl) (caddr pl))))
   
7.    pl (cdr (cdr (cdr pl)))
   
8.    )
   
9.     )
   
10. pts
    
11.   )
    
12. ;;;曲线选择集交点
    
13. (defun ssinters (ss / pts en1 en2)
    
14.   (while (> (sslength ss) 1)
    
15.     (setq en1 (ssname ss 0))
    
16.     (ssdel en1 ss)
    
17.     (setq n (sslength ss))
    
18.     (repeat n
    
19.       (setq en2 (ssname ss (setq n (1- n))))
    
20.       (setq pts (append pts (Curveinters en1 en2)))
    
21.       )
    
22.     )
    
23.   pts
    
24.   )
    
25. ;;;画框
    
26. (defun drawbox (pt d / r en ang)
    
27.   (setq en (ssget pt '((0 . "*line"))))
    
28.   (setq en (ssname en 0))
    
29.   (setq ang (angle pt (mapcar '+ pt (vlax-curve-getFirstDeriv en (vlax-curve-getParamAtPoint en (setq pt (vlax-curve-getclosestpointto en pt)))))))
    
30.   (setq r (* d (sqrt 2)))
    
31.   ;;此处也可改插入框的图块
    
32.   (command "circle" pt 2.0)
    
33.   )
    
34. ;;;使用实例
    
35. (defun c:tt(/ p1 p2 d minX minY maxX maxY pt pts p1 p2 ss os cmdecho)
    
36.   (setq os (getvar "osmode"))
    
37.   (setq cmdecho (getvar "cmdecho"))
    
38.   (setvar "osmode" 0)
    
39.   (setvar "cmdecho" 0)
    
40.   (setq d (getreal "\n插入框大小<1.0>"))
    
41.   (if (null d) (setq d 1.))
    
42.   (while (and
    
43.            (setq p1 (getpoint "\n选择图框左下角："))
    
44.            (setq p2 (GETCORNER p1 "\n选择图框左下角："))
    
45.            )
    
46.     (setq minX (apply 'min (mapcar 'car (list p1 p2)))
    
47.           minY (apply 'min (mapcar 'cadr (list p1 p2)))
    
48.           maxX (apply 'max (mapcar 'car (list p1 p2)))
    
49.           maxY (apply 'max (mapcar 'cadr (list p1 p2)))
    
50.           )
    
51.     (grvecs (list 1 (list minx miny) (list maxx miny)
    
52.                   1 (list maxx miny) (list maxx maxy)
    
53.                   1 (list maxx maxy) (list minx maxy)
    
54.                   1 (list minx maxy) (list minx miny)
    
55.                   )
    
56.             )
    
57.     (setq ss (ssget "c" p1 p2 '((0 . "*line"))))
    
58.     (if ss
    
59.       (progn
    
60.         (setq pts (ssinters ss))
    
61.         (if pts
    
62.           (foreach pt pts
    
63.             (if (and (>= maxX (car pt) minX)
    
64.                      (>= maxY (cadr pt) minY)
    
65.                      )
    
66.               (drawbox pt d)
    
67.               )
    
68.             )
    
69.           )
    
70.         )
    
71.       )
    
72.     (princ "\n ***回车键结束***")
    
73.     )
    
74. (setvar "osmode" os)
    
75.   (setvar "cmdecho" cmdecho)
    
76.   (princ)
    
77. )

;;;计算曲线交点<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 /> ;;;曲线选择集交点<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 /> ;;;画框<br /> (defun drawbox (pt d / r en ang)<br />   (setq en (ssget pt '((0 . "*line"))))<br />   (setq en (ssname en 0))<br />   (setq ang (angle pt (mapcar '+ pt (vlax-curve-getFirstDeriv en (vlax-curve-getParamAtPoint en (setq pt (vlax-curve-getclosestpointto en pt)))))))<br />   (setq r (* d (sqrt 2)))<br />   ;;此处也可改插入框的图块<br />   (command "circle" pt 2.0)<br />   )<br /> ;;;使用实例<br /> (defun c:tt(/ p1 p2 d minX minY maxX maxY pt pts p1 p2 ss os cmdecho)<br />   (setq os (getvar "osmode"))<br />   (setq cmdecho (getvar "cmdecho"))<br />   (setvar "osmode" 0)<br />   (setvar "cmdecho" 0)<br />   (setq d (getreal "\n插入框大小<1.0>"))<br />   (if (null d) (setq d 1.))<br />   (while (and<br />            (setq p1 (getpoint "\n选择图框左下角："))<br />            (setq p2 (GETCORNER p1 "\n选择图框左下角："))<br />            )<br />     (setq minX (apply 'min (mapcar 'car (list p1 p2)))<br />           minY (apply 'min (mapcar 'cadr (list p1 p2)))<br />           maxX (apply 'max (mapcar 'car (list p1 p2)))<br />           maxY (apply 'max (mapcar 'cadr (list p1 p2)))<br />           )<br />     (grvecs (list 1 (list minx miny) (list maxx miny)<br />                   1 (list maxx miny) (list maxx maxy)<br />                   1 (list maxx maxy) (list minx maxy)<br />                   1 (list minx maxy) (list minx miny)<br />                   )<br />             )<br />     (setq ss (ssget "c" p1 p2 '((0 . "*line"))))<br />     (if ss<br />       (progn<br />         (setq pts (ssinters ss))<br />         (if pts<br />           (foreach pt pts<br />             (if (and (>= maxX (car pt) minX)<br />                      (>= maxY (cadr pt) minY)<br />                      )<br />               (drawbox pt d)<br />               )<br />             )<br />           )<br />         )<br />       )<br />     (princ "\n ***回车键结束***")<br />     )<br /> (setvar "osmode" os)<br />   (setvar "cmdecho" cmdecho)<br />   (princ)<br /> )

zyhandw

不支持圆弧和直线交点的插入？
那好办啊，用pedit将圆弧转成多义线就行了！

zyhandw

将圆弧转成多义线啊！