选框倒角和圆角
(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)
(setqa 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)
)
这个lisp可以选框圆角，但不支持pline！
谁可以帮助添加倒角功能，并支持pline (defun c:ffr (/ newrad ss pts i ee)
(setq newrad (getreal "\nPlease enter the filletradius："))
(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")))
i0
)
(while (setq ee (ssname ss i))
(command "Fillet" "P" ee)
(setq i (1+ i))
)
)
该lisp可以支持Pline，但需要ET工具 如果您没有安装ET，我怀疑您没有，请查看（vla getboundingbox）函数以获取每个“直线、圆弧、LWPOLYLINE”实体的数据，并使用获得的点的最小值和最大值-与（acet geom ss extents）函数相同，但需要更多的键入过程。。。
对于倒角-将直线（命令“Fillet”“P”ee）更改为（命令“chamfer”“P”ee），并在前面指定倒角距离。。。
看看我在AUGI发布的这些旧代码-但我现在懒得搜索它们。。。
(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 chptschamfers) chpts (list pt22 (mid (car lin) (cadr lin))) chamfers (conschpts 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))
)
)
HTH，M.R。
哈啊哈！有点懒。。。，非常感谢你！马尔科·里巴，你是万里挑一，没有你我做不到 对不起flyfox1047，我不是故意不礼貌的，我只是想看看当我在床上睡觉的时候你会发什么帖子。。。
然而，由于使用的函数（最小值）和（最大值）非常有限，李的sub对于大量对象不是很可靠。。。
(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)
)
这是在我的机器上选择5760行的结果。。。
正如你所见，我建议你使用我的版本，它更强大，但不会失败：
(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)
)
我用我的版本更新了我以前的帖子。。。
你，马尔科·里巴尔（没有你我做不到！）
非常感谢。M、 你的版本很好！
重复对大量点进行排序效率极低，完全没有必要，因为我们只寻找最小值/最大值。
可以通过以下方式编写代码来绕过参数限制：
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))
李，谢谢！
页:
[1]
2