[编程交流] 选框倒角和圆角

(defun c:fr()
 (setq cm (getvar "cmdecho"))
 (setvar "cmdecho" 0)
 (setvar "osmode" 0)
 (setq rr (getreal "\nPlease enter the radius: ") aa nil)
 (while (setq en (ssget '((0 . "LINE"))))
 (setq n (sslength en) i 1 a 0 )
 (command "fillet" "r" rr "")
 (while n
   (if (= i (- n 1))(setq en2 (entget (handent cc)) aa 0)
  (setq en2 (entget (ssname en a))))
   (setq p1 (cdr (assoc 10 en2)) p2 (cdr (assoc 11 en2)) cc (cdr (assoc 5 en2)) i (+ a 1) ii 1)
  (while ii 
     (if (= i n)(setq ii nil n nil)
       (progn
        (setq en3 (entget (ssname en i)))
        (setq pp1 (cdr (assoc 10 en3)) pp2 (cdr (assoc 11 en3)) bb (cdr (assoc 5 en3)))
        (setq d (distance p1 pp2) d1 (distance p1 pp1) d2 (distance p2 pp2) d1 (distance p2 
pp1) )
        (if (or (= d 0.0)(= d1 0.0)(= d2 0.0)(= d3 0.0))
         (progn
          (setq pp3 (polar pp1 (angle pp1 pp2) (/ (distance pp1 pp2) 2.0)))
          (setq p5 (polar p1 (angle p1 p2) (/ (distance p1 p2) 2.0)))
          (command "fillet" pp3 p5)
          (setq  a i ii nil )
         )
         (setq i (+ i 1))
       )   ;-if d 0.0
     ))
   )   ;-ii
   (if (and (/= n nil)(= i (- n 1)))(setq a 0 i 1))
    (if (and (= aa 0)(= i (- n 1)))(setq n nil))
   )  ;-n
 )
 (setvar "cmdecho" 1)
 (setvar "osmode" 15359)
 (princ)
)

(defun c:ffr (/ newrad ss pts i ee)
  (setq newrad (getreal "\nPlease enter the fillet  radius："))
  (setvar "FilletRad" newrad)
  (setq ss (ssget '(( 0 . "LINE,ARC,LWPOLYLINE"))))
  (setq pts (acet-geom-ss-extents ss nil))     ; ET func
  (SetVar "PeditAccept" 1)
  (command "Pedit" "M" ss "" "J" "" "")
  (setq ss (ssget "C" (car pts) (cadr pts) '(( 0 . "LWPOLYLINE")))
         i  0
  )
  
  (while (setq ee (ssname ss i))
    (command "Fillet" "P" ee)
    (setq i (1+ i))
  )
)

(defun mintfillet ( ss / *error* ape osm tang smallang member-fuzz AssocOn _reml mid frad i ent p1 p2 ptlst linlst aptlst1 aptlst2 arcchk intptlst a1 a2 aa1 aa2 asss1 asss2 ass1 ass2 r rlst maxrad ss2lin ptt1 ptt2 )
 (defun *error* ( msg )
   (if ape (setvar 'aperture ape))
   (if osm (setvar 'osmode osm))
   (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
 )
 (defun tang ( a )
   (/ (sin a) (cos a))
 )
 (defun smallang ( p1 po p2 / sa )
   (if (< (angle po p1) (angle po p2))
     (if (>= (setq sa (+ (- (angle po p1) (angle po p2)) pi pi)) pi)
       (setq sa (- (* 2.0 pi) sa))
     )
     (if (>= (setq sa (+ (- (angle po p2) (angle po p1)) pi pi)) pi)
       (setq sa (- (* 2.0 pi) sa))
     )
   )
   (if (equal (angle po p1) (angle po p2) 1e- (setq sa 0.0))
   sa
 )
 
 (defun member-fuzz ( expr lst fuzz )
   (while (and lst (not (equal (car lst) expr fuzz)))
     (setq lst (cdr lst))
   )
   lst
 )
 
 (defun AssocOn ( SearchTerm Lst func fuzz )
   (car
     (vl-member-if
       (function
         (lambda (pair) (equal SearchTerm (apply func (list pair)) fuzz))
       )
       lst
     )
   )
 )
 
 (defun _reml ( l1 l2 / a n ls )
   (while 
     (setq n nil 
           a (car l2)
     )
     (while (and l1 (null n))
       (if (equal a (car l1) 1e-6)
         (setq l1 (cdr l1) 
               n t
         )
         (setq ls (append ls (list (car l1)))
               l1 (cdr l1)
         )
       )
     )
     (setq l2 (cdr l2))
   )
   (append ls l1)
 )
 (defun mid ( p1 p2 )
   (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
 )
 (setq ape (getvar 'aperture))
 (setq osm (getvar 'osmode))
 (setvar 'aperture 1)
 (setvar 'osmode 0)
 (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
 (setq i -1)
 (while (setq ent (ssname ss (setq i (1+ i))))
   (setq
         p1 (trans (vlax-curve-getStartPoint ent) 0 1)
         p2 (trans (vlax-curve-getEndPoint ent) 0 1)
   )
   (if (= (cdr (assoc 0 (entget ent))) "LINE")
     (setq ptlst (append (list p1 p2) ptlst) linlst (cons (list p1 p2) linlst))
     (progn
       (setq aptlst1 (cons p1 aptlst1) aptlst2 (cons p2 aptlst2) arcchk T)
       (entdel ent)
     )
   )
 )
 (setq intptlst (_reml ptlst (acet-list-remove-duplicates ptlst 1e-6)))
 (if (not arcchk)
   (progn
     (foreach lin linlst
       (cond 
         ( (and (member-fuzz (car lin) intptlst 1e-6) (member-fuzz (cadr lin) intptlst 1e-6))
           (if (setq asss1 (assocon (car lin) (vl-remove lin linlst) 'car 1e-6))
               (setq aa1 (/ (smallang (cadr asss1) (car lin) (cadr lin)) 2.0)) 
           )
           (if (setq asss1 (assocon (car lin) (vl-remove lin linlst) 'cadr 1e-6))
               (setq aa1 (/ (smallang (car asss1) (car lin) (cadr lin)) 2.0)) 
           )
           (if (setq asss2 (assocon (cadr lin) (vl-remove lin linlst) 'car 1e-6))
               (setq aa2 (/ (smallang (cadr asss2) (cadr lin) (car lin)) 2.0)) 
           )
           (if (setq asss2 (assocon (cadr lin) (vl-remove lin linlst) 'cadr 1e-6))
               (setq aa2 (/ (smallang (car asss2) (cadr lin) (car lin)) 2.0)) 
           )
           (setq r (/ (* (distance (car lin) (cadr lin)) (tang aa1) (tang aa2)) (+ (tang aa1) (tang aa2))))
           (setq rlst (cons r rlst))
         )
         ( (and (member-fuzz (car lin) intptlst 1e-6) (not (member-fuzz (cadr lin) intptlst 1e-6)))
           (if (setq ass1 (assocon (car lin) (vl-remove lin linlst) 'car 1e-6))
               (setq a1 (/ (smallang (cadr ass1) (car lin) (cadr lin)) 2.0)) 
           )
           (if (setq ass1 (assocon (car lin) (vl-remove lin linlst) 'cadr 1e-6))
               (setq a1 (/ (smallang (car ass1) (car lin) (cadr lin)) 2.0)) 
           )
           (setq r (* (distance (car lin) (cadr lin)) (tang a1)))
           (setq rlst (cons r rlst))
         )
         ( (and (not (member-fuzz (car lin) intptlst 1e-6)) (member-fuzz (cadr lin) intptlst 1e-6))
           (if (setq ass2 (assocon (cadr lin) (vl-remove lin linlst) 'car 1e-6))
               (setq a2 (/ (smallang (cadr ass2) (cadr lin) (car lin)) 2.0)) 
           )
           (if (setq ass2 (assocon (cadr lin) (vl-remove lin linlst) 'cadr 1e-6))
               (setq a2 (/ (smallang (car ass2) (cadr lin) (car lin)) 2.0)) 
           )
           (setq r (* (distance (car lin) (cadr lin)) (tang a2)))
           (setq rlst (cons r rlst))
         )
       )
     )
     (setq maxrad (car (vl-sort rlst '<)))
   )
   (setq maxrad 0.0)
 )
 (setq frad (getdist (strcat "\nPick radius for fillet <0.0-" (rtos maxrad) "> : ")))
 (if frad (setvar 'filletrad frad))
 (if arcchk
   (mapcar '(lambda ( a b )
              (command "_.zoom" "w" a b)
              (command "_.fillet" (osnap a "_nea") (osnap b "_nea"))
              (command "_.zoom" "p")
            ) aptlst1 aptlst2)
   (if (/= frad 0.0)
     (foreach pt intptlst
       (setq ss2lin (ssget "_C" pt pt))
       (setq ptt1 (mid (mid (trans (vlax-curve-getstartpoint (ssname ss2lin 0)) 0 1) (trans (vlax-curve-getendpoint (ssname ss2lin 0)) 0 1)) pt))
       (setq ptt2 (mid (mid (trans (vlax-curve-getstartpoint (ssname ss2lin 1)) 0 1) (trans (vlax-curve-getendpoint (ssname ss2lin 1)) 0 1)) pt))
       (command "_.fillet" (list (ssname ss2lin 0) ptt1) (list (ssname ss2lin 1) ptt2))
     )
   )
 )
 (*error* nil)
 (princ)
)
(defun c:mif ( / mintfillet )
 (vl-load-com)
 
 (prompt "\nSelect lines touching each other to apply fillet, or select lines and arcs previously filleted to modify existing fillet")
 (while (not (ssget "_:L" '((0 . "LINE,ARC")))))
 (vla-sendcommand (vla-get-activedocument (vlax-get-acad-object)) (strcat "(mintfillet (ssget "_P"))" "\n" "0.0" "\n" "(mintfillet (ssget "_P"))" "\n"))
 (princ)
)

(defun c:mcha ( / *error* mid AssocOn ss i ent p1 p2 lin linn lins flins ptlst1 pt1 pt11 ptlst2 pt2 pt22 chpts chamfers )
 (vl-load-com)
 
 (defun *error* ( msg )
   (if chma (setvar 'chamfera chma))
   (if chmb (setvar 'chamferb chmb))
   (if chmm (setvar 'chammode chmm))
   (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
 )
 (defun mid ( p1 p2 )
   (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
 )
 (defun AssocOn ( SearchTerm Lst func fuzz )
   (car
     (vl-member-if
       (function
         (lambda (pair) (equal SearchTerm (apply func (list pair)) fuzz))
       )
       lst
     )
   )
 )
 (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
 (mapcar 'set '(chma chmb chmm) (mapcar 'getvar '(chamfera chamferb chammode)))
 (mapcar 'setvar '(chamfera chamferb chammode) '(0 0 0))
 (prompt "\nSelect line entities")
 (while (not (setq ss (ssget "_:L" '((0 . "LINE"))))))
 (setq i -1)
 (while (setq ent (ssname ss (setq i (1+ i))))
   (setq p1 (trans (vlax-curve-getstartpoint ent) 0 1))
   (setq p2 (trans (vlax-curve-getendpoint ent) 0 1))
   (setq lin (list p1 p2))
   (setq lins (cons lin lins))
 )
 (setq flins (apply 'append lins))
 (foreach lin lins
   (setq ptlst1 (vl-sort flins '(lambda ( a b ) (< (distance (car lin) a) (distance (car lin) b)))))
   (if (equal (cadr ptlst1) (cadr lin) 1e- (setq pt1 (caddr ptlst1)) (setq pt1 (cadr ptlst1)))
   (if (setq linn (assocon pt1 lins 'car 1e-) (setq pt11 (mid (car linn) (cadr linn))))
   (if (setq linn (assocon pt1 lins 'cadr 1e-) (setq pt11 (mid (car linn) (cadr linn))))
   (setq ptlst2 (vl-sort flins '(lambda ( a b ) (< (distance (cadr lin) a) (distance (cadr lin) b)))))
   (if (equal (cadr ptlst2) (car lin) 1e- (setq pt2 (caddr ptlst2)) (setq pt2 (cadr ptlst2)))
   (if (setq linn (assocon pt2 lins 'car 1e-) (setq pt22 (mid (car linn) (cadr linn))))
   (if (setq linn (assocon pt2 lins 'cadr 1e-) (setq pt22 (mid (car linn) (cadr linn))))
    (setq chpts (list pt11 (mid (car lin) (cadr lin))) chamfers (cons chpts  chamfers) chpts (list pt22 (mid (car lin) (cadr lin))) chamfers (cons  chpts chamfers))
 )
 (foreach chpts chamfers
   (command "_.chamfer" (car chpts) (cadr chpts))
 )
 (*error* nil)
 (princ)
)

(defun LM:ssboundingbox ( s / a b i m n o )
;; Selection Set Bounding Box  -  Lee Mac
   (repeat (setq i (sslength s))
       (if
           (and
               (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
               (vlax-method-applicable-p o 'getboundingbox)
               (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
           )
           (setq m (cons (vlax-safearray->list a) m)
                 n (cons (vlax-safearray->list b) n)
           )
       )
   )
   (if (and m n)
       (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n))
   )
)

(defun MR:ssboundingbox ( s / a b i m n o xmin ymin zmin pmin xmax ymax zmax pmax ) (vl-load-com)
;; Selection Set Bounding Box  -  Marko Ribar
 (repeat (setq i (sslength s))
   (if
     (and
       (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
       (vlax-method-applicable-p o 'getboundingbox)
       (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
     )
     (setq m (cons (vlax-safearray->list a) m)
           n (cons (vlax-safearray->list b) n)
     )
   )
 )
 (if (and m n)
   (progn
     (setq xmin (caar (vl-sort m '(lambda ( a b ) (< (car a) (car b)))))
           ymin (cadar (vl-sort m '(lambda ( a b ) (< (cadr a) (cadr b)))))
           zmin (caddar (vl-sort m '(lambda ( a b ) (< (caddr a) (caddr b)))))
           pmin (list xmin ymin zmin)
     )
     (setq xmax (caar (vl-sort n '(lambda ( a b ) (> (car a) (car b)))))
           ymax (cadar (vl-sort n '(lambda ( a b ) (> (cadr a) (cadr b)))))
           zmax (caddar (vl-sort n '(lambda ( a b ) (> (caddr a) (caddr b)))))
           pmax (list xmax ymax zmax)
     )
     (list pmin pmax)
   )
 )
)
(defun c:ffr ( / *error* pea fira newrad ss pts i ee )
 (defun *error* ( msg )
   (if pea (setvar 'peditaccept pea))
   (if fira (setvar 'filletrad fira))
   (if msg (prompt msg))
   (princ)
 )
 (setq pea (getvar 'peditaccept))
 (setq fira (getvar 'filletrad))
 (if (setq newrad (getdist (strcat "\nPlease enter the fillet radius <" (rtos (getvar 'filletrad)) ">: "))) (abs newrad))
 (if (null newrad) (setq newrad (getvar 'filletrad)))
 (setvar 'filletrad newrad)
 (setq ss (ssget '((0 . "LINE,ARC,LWPOLYLINE"))))
 (setq pts (MR:ssboundingbox ss))
 (setvar 'peditaccept 1)
 (command "_.pedit" "_m" ss "" "_j" "" "")
 (setq ss (ssget "_c" (car pts) (cadr pts) '((0 . "LWPOLYLINE")))
       i -1
 )
 
 (while (setq ee (ssname ss (setq i (1+ i))))
   (command "_.fillet" "_p" ee)
 )
 (*error* nil)
 (princ)
)

(defun MR:ssboundingbox ( s / a b i m n o xmin ymin zmin pmin xmax ymax zmax pmax ) (vl-load-com)
;; Selection Set Bounding Box  -  Marko Ribar
 (repeat (setq i (sslength s))
   (if
     (and
       (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
       (vlax-method-applicable-p o 'getboundingbox)
       (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
     )
     (setq m (cons (vlax-safearray->list a) m)
           n (cons (vlax-safearray->list b) n)
     )
   )
 )
 (if (and m n)
   (progn
     (setq xmin (caar (vl-sort m '(lambda ( a b ) (< (car a) (car b)))))
           ymin (cadar (vl-sort m '(lambda ( a b ) (< (cadr a) (cadr b)))))
           zmin (caddar (vl-sort m '(lambda ( a b ) (< (caddr a) (caddr b)))))
           pmin (list xmin ymin zmin)
     )
     (setq xmax (caar (vl-sort n '(lambda ( a b ) (> (car a) (car b)))))
           ymax (cadar (vl-sort n '(lambda ( a b ) (> (cadr a) (cadr b)))))
           zmax (caddar (vl-sort n '(lambda ( a b ) (> (caddr a) (caddr b)))))
           pmax (list xmax ymax zmax)
     )
     (list pmin pmax)
   )
 )
)
(defun c:cdi ( / *error* pea chaa chab newdst1 newdst2 ss pts i ee )
 (defun *error* ( msg )
   (if pea (setvar 'peditaccept pea))
   (if chaa (setvar 'chamfera chaa))
   (if chab (setvar 'chamferb chab))
   (if msg (prompt msg))
   (princ)
 )
 (setq pea (getvar 'peditaccept))
 (setq chaa (getvar 'chamfera))
 (setq chab (getvar 'chamferb))
 (if (setq newdst1 (getdist (strcat "\nPlease enter the first chamfer distance <" (rtos (getvar 'chamfera)) ">: "))) (abs newdst1))
 (if (null newdst1) (setq newdst1 (getvar 'chamfera)))
 (setvar 'chamfera newdst1)
 (if (setq newdst2 (getdist (strcat "\nPlease enter the second chamfer distance <" (rtos (getvar 'chamfera)) ">: "))) (abs newdst2))
 (if (null newdst2) (setq newdst2 (getvar 'chamfera)))
 (setvar 'chamferb newdst2)
 (setq ss (ssget '((0 . "LINE,ARC,LWPOLYLINE"))))
 (setq pts (MR:ssboundingbox ss))
 (setvar 'peditaccept 1)
 (command "_.pedit" "_m" ss "" "_j" "" "")
 (setq ss (ssget "_c" (car pts) (cadr pts) '((0 . "LWPOLYLINE")))
       i -1
 )
 
 (while (setq ee (ssname ss (setq i (1+ i))))
   (command "_.chamfer" "_p" ee)
 )
 (*error* nil)
 (princ)
)

Command: (setq ss (ssget))
Select objects: Specify opposite corner: 5760 found
Select objects:
<Selection set: 1b1>
Command: (setq bb (lm:ssboundingbox ss))
; error: Exception occurred: 0xC0000005 (Access Violation)
; warning: unwind skipped on exception
; error: Exception occurred: 0xC0000005 (Access Violation)
Command: (setq bb (mr:ssboundingbox ss))
((2.5446 -70.7315 0.0) (141.877 62.9086 0.0))