寻找交点，并且填充

edata

1. ;;; 画直线焦点三角形    by:langjs
   
2. ;;;============================
   
3. (defun c:ww (/ co ent i j lst lst1 lst2 lst3 pt pt1 pt2 pt3 pt4 pt5 r ss ss1 zh)
   
4.   (setvar "cmdecho" 0)
   
5.   (setq zh (getvar "ORTHOMODE"))
   
6.   (setvar "ORTHOMODE" 0)
   
7.   (setq pt1 (getpoint "\n框选直线对象:")pt2 (getcorner pt1 "\指定对角点:")pt3 (list (car pt1) (cadr pt2))pt4 (list (car pt2) (cadr pt1))
   
8.         ss (ssget "CP" (list pt1 pt3 pt2 pt4 pt1) '((0 . "LINE"))))
   
9.   (repeat (setq i (sslength ss)) (redraw (ssname ss (setq i (1- i))) 3))
   
10.   (setq pt5 (getpoint pt1 "\指定方向:")        r (+ (* (fix (/ (angle pt1 pt5) (* 0.5 pi))) 0.5 pi) (* 0.25 pi))lst '())
    
11.   (repeat (setq i (sslength ss))
    
12.     (setq ent (entget (ssname ss (setq i (1- i))))  co (cdr (assoc 62 ent)))
    
13.     (if (not (member co lst))
    
14.       (progn
    
15.         (setq lst (cons co lst)  lst1 '() lst2 '() ss1 (ssget "CP" (list pt1 pt3 pt2 pt4 pt1) (list  '(0 . "LINE"))))
    
16.         (repeat (setq j (sslength ss1))
    
17.           (setq ent (entget (ssname ss1 (setq j (1- j))))lst1 (cons (list (cdr (assoc 10 ent)) (cdr (assoc 11 ent))) lst1)))
    
18.         (setq lst3 lst1)
    
19.         (while lst3
    
20.           (setq pt5 (car lst3))
    
21.           (foreach j lst1
    
22.             (if (and (setq pt (inters  (car pt5)(cadr pt5)(car j)(cadr j))) (not (member pt lst2)))
    
23.               (progn
    
24.                 (setq lst2 (cons pt lst2))
    
25.                 (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") (cons 62 (if co co 256)) '(100 . "AcDbPolyline") '(90 . 2)
    
26.                                (cons 10 pt) (cons 40 0.0) (cons 41 14.14) (cons 10 (polar pt r 7.07)))))));14.14为三角形长边, 7.07为长边一半
    
27.           (setq lst3 (cdr lst3))))))
    
28.   (repeat (setq i (sslength ss)) (redraw (ssname ss (setq i (1- i))) 4))
    
29.   (setvar "ORTHOMODE" zh)
    
30.   (princ)
    
31. )

;;; 画直线焦点三角形    by:langjs<br /> ;;;============================<br /> (defun c:ww (/ co ent i j lst lst1 lst2 lst3 pt pt1 pt2 pt3 pt4 pt5 r ss ss1 zh)<br />   (setvar "cmdecho" 0)<br />   (setq zh (getvar "ORTHOMODE"))<br />   (setvar "ORTHOMODE" 0)<br />   (setq pt1 (getpoint "\n框选直线对象:")pt2 (getcorner pt1 "\指定对角点:")pt3 (list (car pt1) (cadr pt2))pt4 (list (car pt2) (cadr pt1))<br />         ss (ssget "CP" (list pt1 pt3 pt2 pt4 pt1) '((0 . "LINE"))))<br />   (repeat (setq i (sslength ss)) (redraw (ssname ss (setq i (1- i))) 3))<br />   (setq pt5 (getpoint pt1 "\指定方向:")        r (+ (* (fix (/ (angle pt1 pt5) (* 0.5 pi))) 0.5 pi) (* 0.25 pi))lst '())<br />   (repeat (setq i (sslength ss))<br />     (setq ent (entget (ssname ss (setq i (1- i))))  co (cdr (assoc 62 ent)))<br />     (if (not (member co lst))<br />       (progn<br />         (setq lst (cons co lst)  lst1 '() lst2 '() ss1 (ssget "CP" (list pt1 pt3 pt2 pt4 pt1) (list  '(0 . "LINE"))))<br />         (repeat (setq j (sslength ss1))<br />           (setq ent (entget (ssname ss1 (setq j (1- j))))lst1 (cons (list (cdr (assoc 10 ent)) (cdr (assoc 11 ent))) lst1)))<br />         (setq lst3 lst1)<br />         (while lst3<br />           (setq pt5 (car lst3))<br />           (foreach j lst1<br />             (if (and (setq pt (inters  (car pt5)(cadr pt5)(car j)(cadr j))) (not (member pt lst2)))<br />               (progn<br />                 (setq lst2 (cons pt lst2))<br />                 (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") (cons 62 (if co co 256)) '(100 . "AcDbPolyline") '(90 . 2)<br />                                (cons 10 pt) (cons 40 0.0) (cons 41 14.14) (cons 10 (polar pt r 7.07)))))));14.14为三角形长边, 7.07为长边一半<br />           (setq lst3 (cdr lst3))))))<br />   (repeat (setq i (sslength ss)) (redraw (ssname ss (setq i (1- i))) 4))<br />   (setvar "ORTHOMODE" zh)<br />   (princ)<br /> )