实现框选一次性倒R角

aaacjh

求lisp源码实现：，另外还想实现对已倒过圆角进行框选一次性识别修正的lisp源码。
之前学习lisp时，对矩形编写了以下程序，繁杂又有缺陷，特此求助于高手们，望相助！先行谢过！
(defun c:ffr(/ newrad ss i aa bb va i_list new_rlist n_list newcx newcy)
(setq newrad(getreal "\n请输入新的半径："))
(setq ss(ssget))
(setq i 0)
(repeat (sslength ss)
(setq i_list(entget(ssname ss i)))
(if (= (cdr(assoc 0 i_list)) "ARC")
     (progn
       (setq bb(assoc 40 i_list))
       (setq va(- newrad (cdr bb)))
     )
)
)
(setq i 0)
(repeat (sslength ss)
(setq i_list(entget(ssname ss i)))
(cond
((= (cdr(assoc 0 i_list)) "ARC")
  (setq new_rlist(cons 40 newrad));创建一个新表
  (setq aa(assoc 10 i_list))
  (setq i_list(subst new_rlist bb i_list))
  (cond
   ((= 0 (cdr(assoc 50 i_list)))
    (setq newcx(- (cadr aa) va))
    (setq newcy(- (caddr aa) va))
    (setq n_list(subst newcx (cadr aa) aa))
    (setq n_list(subst newcy (caddr aa) n_list))
    (setq i_list(subst n_list aa i_list))
    (entmod i_list)
   );;;;;第一象限圆角
   ((= (/ pi 2) (cdr(assoc 50 i_list)))
    (setq newcx(+ (cadr aa) va))
    (setq newcy(- (caddr aa) va))
    (setq n_list(subst newcx (cadr aa) aa))
    (setq n_list(subst newcy (caddr aa) n_list))
    (setq i_list(subst n_list aa i_list))
    (entmod i_list)
   );;;;;第二象限圆角
  
   ((= pi (cdr(assoc 50 i_list)))
    (setq newcx(+ (cadr aa) va))
    (setq newcy(+ (caddr aa) va))
    (setq n_list(subst newcx (cadr aa) aa))
    (setq n_list(subst newcy (caddr aa) n_list))
    (setq i_list(subst n_list aa i_list))
    (entmod i_list)
   );;;;;第三象限圆角
   ((= (/ (* 3 pi) 2) (cdr(assoc 50 i_list)))
    (setq newcx(- (cadr aa) va))
    (setq newcy(+ (caddr aa) va))
    (setq n_list(subst newcx (cadr aa) aa))
    (setq n_list(subst newcy (caddr aa) n_list))
    (setq i_list(subst n_list aa i_list))
    (entmod i_list)
   );;;;;第四象限圆角
))
  
((= (cdr(assoc 0 i_list)) "LINE")
  (setq s10(assoc 10 i_list))
  (setq s11(assoc 11 i_list))
  (setq a10(cadr s10))
  (setq a11(cadr s11))
  (setq t10(caddr s10))
  (setq t11(caddr s11))
  (cond
      ((> t10 t11)  
      (setq td10(subst (- t10 (abs va)) t10 s10))
      (setq i_list(subst td10 s10 i_list))
      (setq td11(subst (+ t11 (abs va)) t11 s11))
      (setq i_list(subst td11 s11 i_list))
      (entmod i_list))
      ((< t10 t11)
      (setq td10(subst (+ t10 (abs va)) t10 s10))
      (setq i_list(subst td10 s10 i_list))
      (setq td11(subst (- t11 (abs va)) t11 s11))
      (setq i_list(subst td11 s11 i_list))
      (entmod i_list))
      ((> a10 a11)  
      (setq ad10(subst (- a10 (abs va)) a10 s10))
      (setq i_list(subst ad10 s10 i_list))
      (setq ad11(subst (+ a11 (abs va)) a11 s11))
      (setq i_list(subst ad11 s11 i_list))
      (entmod i_list))
      ((< a10 a11)  
      (setq ad10(subst (+ a10 (abs va)) a10 s10))
      (setq i_list(subst ad10 s10 i_list))
      (setq ad11(subst (- a11 (abs va)) a11 s11))
      (setq i_list(subst ad11 s11 i_list))
      (entmod i_list))
  );修剪直线
)
)
(setq i(1+ i))
)
(print "批量修改成功!")
)

ketxu

I changed it to not depend on Express function

1. (defun c:fps (/  ss pts i ee :ST:SS-Boundingbox :ST:SS->List :ST:SS->ListVla LM:ssget os ov)
   
2. (setq
   
3.         os '(PeditAccept cmdecho)
   
4.         ov (mapcar 'getvar os)
   
5. )
   
6. (mapcar 'setvar os '(1 0))
   
7. (defun LM:ssget ( msg arg / sel )
   
8.     (princ msg)
   
9.     (setvar 'nomutt 1)
   
10.     (setq sel (vl-catch-all-apply 'ssget arg))
    
11.     (setvar 'nomutt 0)
    
12.     (if (not (vl-catch-all-error-p sel)) sel)
    
13. )
    
14. ;Return list ename from ssget
    
15. (defun :ST:SS->List(ss / n e l)
    
16.   (setq n (sslength ss))
    
17.   (while (setq e (ssname ss (setq n (1- n))))
    
18.     (setq l (cons e l))
    
19.   )  
    
20. )
    
21. ;Return list vla Object from s
    
22. (defun :ST:SS->ListVla(s)(mapcar 'vlax-ename->vla-object (:ST:SS->List s)))
    
23. (defun :ST:SS-Boundingbox ( lst / llp ls1 ls2 urp )
    
24.     (foreach obj lst
    
25.         (vla-getboundingbox obj 'llp 'urp)
    
26.         (setq ls1 (cons (vlax-safearray->list llp) ls1)
    
27.               ls2 (cons (vlax-safearray->list urp) ls2)
    
28.         )
    
29.     )
    
30.     (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list ls1 ls2))
    
31. )
    
32.            (or  *newrad* (setq *newrad* 1))        
    
33.    (setq *newrad* (getdist (strcat "\nB\U+00E1n k\U+00EDnh fillet <" (rtos *newrad*) "> :")))
    
34.    (setvar "FilletRad" *newrad*)
    
35.    ;(setq ss (ssget '(( 0 . "LINE,ARC,LWPOLYLINE"))))
    
36.    (setq ss (LM:ssget "Select Line, Arc, Pline to fillet :" (list '(( 0 . "LINE,ARC,LWPOLYLINE")))))
    
37. 
    
38.    (setq pts (:ST:SS-Boundingbox (:ST:SS->ListVla ss )))     ; ET func
    
39.    
    
40.    (command "edit" "M" ss "" "J" "" "")
    
41.    (setq ss (ssget "C" (car pts) (cadr pts) '(( 0 . "LWPOLYLINE")))
    
42.           i  0
    
43.    )
    
44.    
    
45.    (while (setq ee (ssname ss i))
    
46.      (command "Fillet" "" ee)
    
47.      (setq i (1+ i))
    
48.    )
    
49.    (mapcar 'setvar os ov)
    
50.    (princ)
    
51. )

(defun c:fps (/  ss pts i ee :ST:SS-Boundingbox :ST:SS->List :ST:SS->ListVla LM:ssget os ov)<br /> (setq<br />         os '(PeditAccept cmdecho)<br />         ov (mapcar 'getvar os)<br /> )<br /> (mapcar 'setvar os '(1 0))<br /> (defun LM:ssget ( msg arg / sel )<br />     (princ msg)<br />     (setvar 'nomutt 1)<br />     (setq sel (vl-catch-all-apply 'ssget arg))<br />     (setvar 'nomutt 0)<br />     (if (not (vl-catch-all-error-p sel)) sel)<br /> )<br /> ;Return list ename from ssget<br /> (defun :ST:SS->List(ss / n e l)<br />   (setq n (sslength ss))<br />   (while (setq e (ssname ss (setq n (1- n))))<br />     (setq l (cons e l))<br />   )  <br /> )<br /> ;Return list vla Object from s<br /> (defun :ST:SS->ListVla(s)(mapcar 'vlax-ename->vla-object (:ST:SS->List s)))<br /> (defun :ST:SS-Boundingbox ( lst / llp ls1 ls2 urp )<br />     (foreach obj lst<br />         (vla-getboundingbox obj 'llp 'urp)<br />         (setq ls1 (cons (vlax-safearray->list llp) ls1)<br />               ls2 (cons (vlax-safearray->list urp) ls2)<br />         )<br />     )<br />     (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list ls1 ls2))<br /> )<br />            (or  *newrad* (setq *newrad* 1))        <br />    (setq *newrad* (getdist (strcat "\nB\U+00E1n k\U+00EDnh fillet <" (rtos *newrad*) "> :")))<br />    (setvar "FilletRad" *newrad*)<br />    ;(setq ss (ssget '(( 0 . "LINE,ARC,LWPOLYLINE"))))<br />    (setq ss (LM:ssget "Select Line, Arc, Pline to fillet :" (list '(( 0 . "LINE,ARC,LWPOLYLINE")))))<br /> <br />    (setq pts (:ST:SS-Boundingbox (:ST:SS->ListVla ss )))     ; ET func<br />    <br />    (command "<img src="static/image/smiley/default/titter.gif" smilieid="9" border="0" alt="" />edit" "M" ss "" "J" "" "")<br />    (setq ss (ssget "C" (car pts) (cadr pts) '(( 0 . "LWPOLYLINE")))<br />           i  0<br />    )<br />    <br />    (while (setq ee (ssname ss i))<br />      (command "Fillet" "<img src="static/image/smiley/default/titter.gif" smilieid="9" border="0" alt="" />" ee)<br />      (setq i (1+ i))<br />    )<br />    (mapcar 'setvar os ov)<br />    (princ)<br /> )

下文没句号。

ketxu 发表于 2019-11-4 14:56
I changed it to not depend on Express function

这个可以 就是英文的Bán kính fillet <10.0000> :  Select Line, Arc, Pline to fillet :

utx552258

人家解释，我想，这世界上又要多我这一个疯子了

Andyhon

2. 
   
3. (defun c:ffr (/ newrad ss pts i ee)
   
4.    (setq newrad (getreal "\n请输入新的半径："))
   
5.    (setvar "FilletRad" newrad)
   
6.    (setq ss (ssget '(( 0 . "LINE,ARC,LWPOLYLINE"))))
   
7. 
   
8.    (setq pts (acet-geom-ss-extents ss nil))     ; ET func
   
9.    (SetVar "PeditAccept" 1)
   
10.    (command "Pedit" "M" ss "" "J" "" "")
    
11.    (setq ss (ssget "C" (car pts) (cadr pts) '(( 0 . "LWPOLYLINE")))
    
12.           i  0
    
13.    )
    
14.    
    
15.    (while (setq ee (ssname ss i))
    
16.      (command "Fillet" "P" ee)
    
17.      (setq i (1+ i))
    
18.    )
    
19. )
    

<br /> (defun c:ffr (/ newrad ss pts i ee)<br />    (setq newrad (getreal "\n请输入新的半径："))<br />    (setvar "FilletRad" newrad)<br />    (setq ss (ssget '(( 0 . "LINE,ARC,LWPOLYLINE"))))<br /> <br />    (setq pts (acet-geom-ss-extents ss nil))     ; ET func<br />    (SetVar "PeditAccept" 1)<br />    (command "Pedit" "M" ss "" "J" "" "")<br />    (setq ss (ssget "C" (car pts) (cadr pts) '(( 0 . "LWPOLYLINE")))<br />           i  0<br />    )<br />    <br />    (while (setq ee (ssname ss i))<br />      (command "Fillet" "P" ee)<br />      (setq i (1+ i))<br />    )<br /> )<br />

smartstar

做个记号:-)

aaacjh

Andyhon 发表于 2012-5-18 10:55

运行老出现：错误: no function definition: ACET-GEOM-SS-EXTENTS
不知是什么问题？

Andyhon

http://www.google.com/search?as_ ... A%2F%2Fbbs.mjtd.com

aaacjh

Andyhon 发表于 2012-5-18 10:55

长老，您的源码没有效果阿。还有 (setq pts (acet-geom-ss-extents ss nil))     ; ET func
这句是什么意思阿。

Andyhon

http://bbs.mjtd.com/thread-20113-1-1.html
您得学会搜寻喂
acet-geom-ss-extents 得安装 Express Tools
站内有替代方案...

注册

不错，用力效果很好啊

huxupj

我也正需要顶一个！