[编程交流] 一对多圆角

(defun c:filletlines ( / 3d2d v^v unit acos angle3d marc ss i li lil lixl lill p pl ml lilr sp ep p1 p2 rlpl r gr p a ip d v aep1 aep2 li cp dd arc arcl x )
 (vl-load-com)
 (defun 3d2d ( p )
   (mapcar '+ '(0.0 0.0) p)
 )
 (defun v^v ( u v )
   (mapcar '(lambda ( s1 s2 a b ) (+ ((eval s1) (* (nth a u) (nth b v))) ((eval s2) (* (nth a v) (nth b u))))) '(+ - +) '(- + -) '(1 0 0) '(2 2 1))
 )
 (defun unit ( v )
   (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
 )
 (defun acos ( x )
   (cond
     ((equal x 1.0 1e- 0.0)
     ((equal x -1.0 1e- pi)
     ((equal x 0.0 1e- (/ pi 2.0))
     ((equal x -0.0 1e- (* 3.0 (/ pi 2.0)))
     ((atan (/ (sqrt (- 1.0 (* x x))) x)))
   )
 )
 (defun angle3d ( p1 por p2 / vec1 vec2 dd ang )
   (setq vec1 (unit (mapcar '- p1 por))
         vec2 (unit (mapcar '- p2 por))
         dd (distance vec1 vec2)
         ang (acos (- 1.0 (/ (expt dd 2) 2.0)))
   )
   (if (minusp ang) (+ ang pi) ang)
 )
 (defun marc ( c p1 p2 / dxf10 dxf40 dxf210 dxf50 dxf51 uz )
   (setq dxf10 (trans c 0 (setq uz (v^v (mapcar '- p1 c) (mapcar '- p2 c)))))
   (setq dxf40 (distance c p1))
   (setq dxf210 (unit uz))
   (setq dxf50 (angle dxf10 (trans p1 0 uz)))
   (setq dxf51 (angle dxf10 (trans p2 0 uz)))
   (entmakex (list '(0 . "ARC") '(100 . "AcDbEntity") '(100 . "AcDbCircle") (cons 10 dxf10) (cons 40 dxf40) (cons 210 dxf210) '(100 . "AcDbArc") (cons 50 dxf50) (cons 51 dxf51)))
 )
 (prompt "\nSelect intersecting lines...")
 (setq ss (ssget "_:L" '((0 . "LINE"))))
 (while (not ss)
   (prompt "\nEmpty sel.set... Please select intersecting lines again...")
   (setq ss (ssget "_:L" '((0 . "LINE"))))
 )
 (repeat (setq i (sslength ss))
   (setq li (ssname ss (setq i (1- i))))
   (setq lil (cons li lil))
   (setq lixl (cons (entget li) lixl))
 )
 (setq lill lil)
 (foreach li1 lil
   (setq lill (vl-remove li1 lill))
   (foreach li2 lill
     (if (setq p (vlax-invoke (vlax-ename->vla-object li1) 'intersectwith (vlax-ename->vla-object li2) acextendnone))
       (setq pl (cons p pl))
     )
   )
 )
 (if (null pl)
   (progn
     (prompt "\nLines don't intersect... Restart routine and choose lines that intersect each other... Quitting...")
     (exit)
   )
   (vl-some '(lambda ( x ) (if (vl-every '(lambda ( p ) (vlax-curve-getparamatpoint x p)) pl) (setq ml x))) lil)
 )
 (setq lilr (vl-remove ml lil))
 (setq sp (trans (cdr (assoc 10 (entget ml))) 0 1) ep (trans (cdr (assoc 11 (entget ml))) 0 1))
 (foreach li lilr
   (setq p1 (trans (cdr (assoc 10 (entget li))) 0 1) p2 (trans (cdr (assoc 11 (entget li))) 0 1))
   (setq rlpl (cons (list li (vl-some '(lambda ( p ) (if (vlax-curve-getparamatpoint li p) p nil)) pl) (list p1 p2)) rlpl))
 )
 (initget 7)
 (setq r (getdist "\nPick or specify fillet radius : "))
 (foreach rlp rlpl
   (if (eq (cadr rlp) nil) (setq rlpl (vl-remove rlp rlpl)))
 )
 (prompt "\nMove mouse around selected lines and when desired fillets are displayed click mouse button to accept...")
 (while (and (/= (car (setq gr (grread t))) 3) (/= (car gr) 11) (/= (car gr) 25))
   (if (< (distance (setq p (cadr gr)) sp) (distance p ep))
     (progn
       (if (null x)
         (progn
           (if arcl 
             (progn
               (mapcar 'entdel arcl)
               (setq arcl nil)
             )
           )
           (mapcar '(lambda ( x ) (entmod x)) lixl)
           (setq rlpl (vl-sort rlpl '(lambda ( a b ) (< (distance (cadr a) (cdr (assoc 10 (entget ml)))) (distance (cadr b) (cdr (assoc 10 (entget ml))))))))
           (foreach rlp rlpl
             (if (or
                   (equal (distance (3d2d (cadr (caddr rlp))) (setq ip (inters (3d2d (cadr (caddr rlp))) (3d2d p) (3d2d sp) (3d2d ep) nil))) (+ (distance (3d2d (cadr (caddr rlp))) (3d2d p)) (distance (3d2d p) ip)) 1e-6)
                   (equal (distance (3d2d (cadr (caddr rlp))) (setq ip (inters (3d2d (cadr (caddr rlp))) (3d2d p) (3d2d sp) (3d2d ep) nil))) (+ (distance (3d2d (cadr (caddr rlp))) (3d2d p)) (distance (3d2d (cadr (caddr rlp))) ip)) 1e-6)
                 )
               (progn
                 (setq a (angle3d (cdr (assoc 10 (entget ml))) (cadr rlp) (cdr (assoc 11 (entget (car rlp))))))
                 (setq d (/ r (/ (sin (/ a 2.0)) (cos (/ a 2.0)))))
                 (setq v (unit (mapcar '- (cdr (assoc 11 (entget (car rlp)))) (cdr (assoc 10 (entget (car rlp)))))))
                 (entmod (subst (cons 10 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d)))) (assoc 10 (entget (car rlp))) (entget (car rlp))))
                 (setq aep1 (cdr (assoc 10 (entget (car rlp)))))
                 (setq v (unit (mapcar '- (cdr (assoc 10 (entget ml))) (cdr (assoc 11 (entget ml))))))
                 (setq aep2 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d))))
                 (setq li (entmakex (list '(0 . "LINE") (cons 10 (cadr rlp)) (cons 11 (mapcar '/ (mapcar '+ aep1 aep2) (list 2.0 2.0 2.0))))))
                 (setq cp (vlax-curve-getclosestpointto li aep1 t))
                 (setq v (unit (mapcar '- (cadr rlp) cp)))
                 (setq cp (mapcar '+ (cadr rlp) (list (* (- (car v)) (setq dd (sqrt (+ (expt d 2) (expt r 2))))) (* (- (cadr v)) dd) (* (- (caddr v)) dd))))
                 (setq arc (marc cp aep1 aep2))
                 (setq arcl (cons arc arcl))
                 (entdel li)
               )
               (progn
                 (setq a (angle3d (cdr (assoc 10 (entget ml))) (cadr rlp) (cdr (assoc 10 (entget (car rlp))))))
                 (setq d (/ r (/ (sin (/ a 2.0)) (cos (/ a 2.0)))))
                 (setq v (unit (mapcar '- (cdr (assoc 10 (entget (car rlp)))) (cdr (assoc 11 (entget (car rlp)))))))
                 (entmod (subst (cons 11 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d)))) (assoc 11 (entget (car rlp))) (entget (car rlp))))
                 (setq aep1 (cdr (assoc 11 (entget (car rlp)))))
                 (setq v (unit (mapcar '- (cdr (assoc 10 (entget ml))) (cdr (assoc 11 (entget ml))))))
                 (setq aep2 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d))))
                 (setq li (entmakex (list '(0 . "LINE") (cons 10 (cadr rlp)) (cons 11 (mapcar '/ (mapcar '+ aep1 aep2) (list 2.0 2.0 2.0))))))
                 (setq cp (vlax-curve-getclosestpointto li aep1 t))
                 (setq v (unit (mapcar '- (cadr rlp) cp)))
                 (setq cp (mapcar '+ (cadr rlp) (list (* (- (car v)) (setq dd (sqrt (+ (expt d 2) (expt r 2))))) (* (- (cadr v)) dd) (* (- (caddr v)) dd))))
                 (setq arc (marc cp aep1 aep2))
                 (setq arcl (cons arc arcl))
                 (entdel li)
               )
             )
           )
           (entmod (subst (cons 11 aep2) (assoc 11 (entget ml)) (entget ml)))
           (setq x t)
         )
       )
     )
     (progn
       (if x
         (progn
           (if arcl 
             (progn
               (mapcar 'entdel arcl)
               (setq arcl nil)
             )
           )
           (mapcar '(lambda ( x ) (entmod x)) lixl)
           (setq rlpl (vl-sort rlpl '(lambda ( a b ) (< (distance (cadr a) (cdr (assoc 11 (entget ml)))) (distance (cadr b) (cdr (assoc 11 (entget ml))))))))
           (foreach rlp rlpl
             (if (or
                   (equal (distance (3d2d (cadr (caddr rlp))) (setq ip (inters (3d2d (cadr (caddr rlp))) (3d2d p) (3d2d sp) (3d2d ep) nil))) (+ (distance (3d2d (cadr (caddr rlp))) (3d2d p)) (distance (3d2d p) ip)) 1e-6)
                   (equal (distance (3d2d (cadr (caddr rlp))) (setq ip (inters (3d2d (cadr (caddr rlp))) (3d2d p) (3d2d sp) (3d2d ep) nil))) (+ (distance (3d2d (cadr (caddr rlp))) (3d2d p)) (distance (3d2d (cadr (caddr rlp))) ip)) 1e-6)
                 )
               (progn
                 (setq a (angle3d (cdr (assoc 11 (entget ml))) (cadr rlp) (cdr (assoc 11 (entget (car rlp))))))
                 (setq d (/ r (/ (sin (/ a 2.0)) (cos (/ a 2.0)))))
                 (setq v (unit (mapcar '- (cdr (assoc 11 (entget (car rlp)))) (cdr (assoc 10 (entget (car rlp)))))))
                 (entmod (subst (cons 10 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d)))) (assoc 10 (entget (car rlp))) (entget (car rlp))))
                 (setq aep1 (cdr (assoc 10 (entget (car rlp)))))
                 (setq v (unit (mapcar '- (cdr (assoc 11 (entget ml))) (cdr (assoc 10 (entget ml))))))
                 (setq aep2 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d))))
                 (setq li (entmakex (list '(0 . "LINE") (cons 10 (cadr rlp)) (cons 11 (mapcar '/ (mapcar '+ aep1 aep2) (list 2.0 2.0 2.0))))))
                 (setq cp (vlax-curve-getclosestpointto li aep1 t))
                 (setq v (unit (mapcar '- (cadr rlp) cp)))
                 (setq cp (mapcar '+ (cadr rlp) (list (* (- (car v)) (setq dd (sqrt (+ (expt d 2) (expt r 2))))) (* (- (cadr v)) dd) (* (- (caddr v)) dd))))
                 (setq arc (marc cp aep1 aep2))
                 (setq arcl (cons arc arcl))
                 (entdel li)
               )
               (progn
                 (setq a (angle3d (cdr (assoc 11 (entget ml))) (cadr rlp) (cdr (assoc 10 (entget (car rlp))))))
                 (setq d (/ r (/ (sin (/ a 2.0)) (cos (/ a 2.0)))))
                 (setq v (unit (mapcar '- (cdr (assoc 10 (entget (car rlp)))) (cdr (assoc 11 (entget (car rlp)))))))
                 (entmod (subst (cons 11 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d)))) (assoc 11 (entget (car rlp))) (entget (car rlp))))
                 (setq aep1 (cdr (assoc 11 (entget (car rlp)))))
                 (setq v (unit (mapcar '- (cdr (assoc 11 (entget ml))) (cdr (assoc 10 (entget ml))))))
                 (setq aep2 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d))))
                 (setq li (entmakex (list '(0 . "LINE") (cons 10 (cadr rlp)) (cons 11 (mapcar '/ (mapcar '+ aep1 aep2) (list 2.0 2.0 2.0))))))
                 (setq cp (vlax-curve-getclosestpointto li aep1 t))
                 (setq v (unit (mapcar '- (cadr rlp) cp)))
                 (setq cp (mapcar '+ (cadr rlp) (list (* (- (car v)) (setq dd (sqrt (+ (expt d 2) (expt r 2))))) (* (- (cadr v)) dd) (* (- (caddr v)) dd))))
                 (setq arc (marc cp aep1 aep2))
                 (setq arcl (cons arc arcl))
                 (entdel li)
               )
             )
           )
           (entmod (subst (cons 10 aep2) (assoc 10 (entget ml)) (entget ml)))
           (setq x nil)
         )
       )
     )
   )
 )
 (princ)
)