flyfox1047 发表于 2022-7-5 23:49:17

选框倒角和圆角

(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

flyfox1047 发表于 2022-7-5 23:56:26

(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工具

marko_ribar 发表于 2022-7-6 00:06:43

如果您没有安装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)
)

flyfox1047 发表于 2022-7-6 00:10:47

他们在这里-不得不睡觉,你很懒。。。
 

(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。

marko_ribar 发表于 2022-7-6 00:13:42

 
哈啊哈!有点懒。。。,非常感谢你!马尔科·里巴,你是万里挑一,没有你我做不到

marko_ribar 发表于 2022-7-6 00:23:03

对不起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)
)

 
我用我的版本更新了我以前的帖子。。。
你,马尔科·里巴尔(没有你我做不到!)

flyfox1047 发表于 2022-7-6 00:29:34

 
非常感谢。M、 你的版本很好!

marko_ribar 发表于 2022-7-6 00:31:59

 
重复对大量点进行排序效率极低,完全没有必要,因为我们只寻找最小值/最大值。
 
 
可以通过以下方式编写代码来绕过参数限制:

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))

flyfox1047 发表于 2022-7-6 00:40:17

李,谢谢!

Lee Mac 发表于 2022-7-6 00:44:15

页: [1] 2
查看完整版本: 选框倒角和圆角